diff --git a/.github/workflows/no-fortran.yml b/.github/workflows/no-fortran.yml new file mode 100644 index 000000000000..96f040590f81 --- /dev/null +++ b/.github/workflows/no-fortran.yml @@ -0,0 +1,40 @@ +name: No Fortran compiler build + +on: + pull_request: + +permissions: + contents: read # to fetch code (actions/checkout) + +jobs: + no_fortran: + runs-on: macos-latest + steps: + - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 + with: + submodules: recursive + + - uses: prefix-dev/setup-pixi@ba3bb36eb2066252b2363392b7739741bb777659 # v0.8.1 + with: + pixi-version: v0.62.0 + run-install: false + + - name: Install test environment + run: pixi global install --with=pyyaml --environment=test python pytest + + - name: Build and install SciPy + run: BUILD_EDITABLE_PYTHON=false pixi global install --environment=test --path . + + - name: Show SciPy config + working-directory: tools + run: python -c 'import scipy; scipy.show_config()' + + - name: Test `scipy.linalg` + working-directory: tools + run: | + python -c " + import scipy, pytest + from pathlib import Path + linalg = Path(scipy.linalg.__file__).parent + pytest.main(linalg) + " diff --git a/meson.build b/meson.build index 9458e16bcee9..5dba55b8e37b 100644 --- a/meson.build +++ b/meson.build @@ -81,27 +81,7 @@ endif if host_machine.system() == 'os400' # IBM i system, needed to avoid build errors - see gh-17193 add_project_arguments('-D__STDC_FORMAT_MACROS', language : 'cpp') - add_project_link_arguments('-Wl,-bnotextro', language : ['c', 'cpp', 'fortran']) -endif - -# Adding at project level causes many spurious -lgfortran flags. -add_languages('fortran', native: false) -ff = meson.get_compiler('fortran') -if ff.get_id() == 'gcc' - # -std=legacy is not supported by all Fortran compilers, but very useful with - # gfortran since it avoids a ton of warnings that we don't care about. - # Needs fixing in Meson, see https://github.com/mesonbuild/meson/issues/11633. - add_project_arguments('-std=legacy', language: 'fortran') -endif - -if ff.has_argument('-Wno-conversion') - add_project_arguments('-Wno-conversion', language: 'fortran') -endif - -if ff.get_id() == 'llvm-flang' - add_project_arguments('-D_CRT_SECURE_NO_WARNINGS', language: ['fortran']) - # -Wall warnings are visible because Meson's warning_level defaults to 1 (-Wall) - # LLVM tracking issue: https://github.com/llvm/llvm-project/issues/89888 + add_project_link_arguments('-Wl,-bnotextro', language : ['c', 'cpp']) endif if cc.get_id() == 'clang-cl' @@ -118,7 +98,7 @@ endif if host_machine.system() == 'darwin' if cc.has_link_argument('-Wl,-dead_strip') # Allow linker to strip unused symbols - add_project_link_arguments('-Wl,-dead_strip', language : ['c', 'cpp', 'fortran']) + add_project_link_arguments('-Wl,-dead_strip', language : ['c', 'cpp']) endif endif @@ -142,22 +122,7 @@ if cc.get_id() in ['intel', 'intel-llvm'] elif cc.get_id() in ['intel-cl', 'intel-llvm-cl'] _intel_cflags += cc.get_supported_arguments('/fp:strict') endif -if ff.get_id() in ['intel', 'intel-llvm'] - _intel_fflags = ff.get_supported_arguments('-fp-model=strict') - minus0_arg = ['-assume', 'minus0'] - if ff.has_multi_arguments(minus0_arg) - _intel_fflags += minus0_arg - endif -elif ff.get_id() in ['intel-cl', 'intel-llvm-cl'] - # Intel Fortran on Windows does things differently, so deal with that - # (also specify dynamic linking and the right name mangling) - _intel_fflags = ff.get_supported_arguments( - '/fp:strict', '/MD', '/names:lowercase', '/assume:underscore', - '/assume:minus0' - ) -endif add_global_arguments(_intel_cflags, language: ['c', 'cpp']) -add_global_arguments(_intel_fflags, language: 'fortran') # Hide symbols when building on Linux with GCC. For Python extension modules, # we only need `PyInit_*` to be public, anything else may cause problems. So we diff --git a/pixi.toml b/pixi.toml index ef4e8de758b7..ecb67e3e30b8 100644 --- a/pixi.toml +++ b/pixi.toml @@ -3,8 +3,37 @@ name = "scipy" description = "Fundamental algorithms for scientific computing in Python." authors = ["SciPy Developers "] channels = ["https://prefix.dev/conda-forge"] -platforms = ["linux-64", "osx-arm64", "win-64"] +# platforms = ["linux-64", "osx-arm64", "win-64"] +platforms = ["osx-arm64"] +preview = ["pixi-build"] + +[package] +license = "BSD-3-Clause" + +[package.build.backend] +name = "pixi-build-python" +version = "*" + +[package.build.config] +compilers = ["c", "cxx"] +env.CXXFLAGS = "${CXXFLAGS} -D_LIBCPP_DISABLE_AVAILABILITY" +[package.host-dependencies] +python = "*" +meson = "*" +meson-python = "*" +pkg-config = "*" +ninja = "*" +cmake = "*" +numpy = "*" +cython = "*" +pythran = "*" +openblas = "*" +pybind11 = "*" +uv = "*" + +[package.run-dependencies] +numpy = "*" ### Environments ### # We include one build task (and a corresponding environment) per solve group diff --git a/scipy/linalg/meson.build b/scipy/linalg/meson.build index 5bd12a443681..08d6ecfa813c 100644 --- a/scipy/linalg/meson.build +++ b/scipy/linalg/meson.build @@ -50,7 +50,7 @@ linalg_cython_gen = generator(cython, # fblas fblas_module = custom_target('fblas_module', - output: ['_fblasmodule.c', '_fblas-f2pywrappers.f'], + output: ['_fblasmodule.c'], input: 'fblas.pyf.src', command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] + f2py_freethreading_arg, depend_files: @@ -116,7 +116,7 @@ py3.extension_module('_flapack', # in azure-pipelines.yml if you want to check that). if use_ilp64 fblas64_module = custom_target('fblas64_module', - output: ['_fblas_64module.c', '_fblas_64-f2pywrappers.f'], + output: ['_fblas_64module.c'], input: 'fblas_64.pyf.src', command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] + f2py_ilp64_opts + f2py_freethreading_arg, depend_files: @@ -138,7 +138,7 @@ if use_ilp64 ) flapack64_module = custom_target('flapack64_module', - output: ['_flapack_64module.c', '_flapack_64-f2pywrappers.f'], + output: ['_flapack_64module.c'], input: 'flapack_64.pyf.src', command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] + f2py_ilp64_opts + f2py_freethreading_arg, ) diff --git a/scipy/meson.build b/scipy/meson.build index 16ba1ddaa0e2..73a66a66a3af 100644 --- a/scipy/meson.build +++ b/scipy/meson.build @@ -2,9 +2,6 @@ fs = import('fs') # Platform detection is_mingw = is_windows and cc.get_id() == 'gcc' -if is_mingw and ff.get_id() != 'gcc' - error('If you are using GCC on Windows, you must also use GFortran! Detected ' + ff.get_id()) -endif cython_c_args = ['-DCYTHON_CCOMPLEX=0'] # see gh-18975 for why we need this if is_mingw @@ -597,51 +594,8 @@ cpp_args_pythran += [ _cpp_Wno_int_in_bool_context, ] -# Fortran warning flags -_fflag_Wno_argument_mismatch = ff.get_supported_arguments('-Wno-argument-mismatch') -_fflag_Wno_conversion = ff.get_supported_arguments('-Wno-conversion') -_fflag_Wno_intrinsic_shadow = ff.get_supported_arguments('-Wno-intrinsic-shadow') -_fflag_Wno_maybe_uninitialized = ff.get_supported_arguments('-Wno-maybe-uninitialized') -_fflag_Wno_surprising = ff.get_supported_arguments('-Wno-surprising') -_fflag_Wno_uninitialized = ff.get_supported_arguments('-Wno-uninitialized') -_fflag_Wno_unused_dummy_argument = ff.get_supported_arguments('-Wno-unused-dummy-argument') -_fflag_Wno_unused_label = ff.get_supported_arguments('-Wno-unused-label') -_fflag_Wno_unused_variable = ff.get_supported_arguments('-Wno-unused-variable') -_fflag_Wno_tabs = ff.get_supported_arguments('-Wno-tabs') -# The default list of warnings to ignore from Fortran code. There is a lot of -# old, vendored code that is very bad and we want to compile it silently (at -# least with GCC and Clang) -fortran_ignore_warnings = ff.get_supported_arguments( - _fflag_Wno_argument_mismatch, - _fflag_Wno_conversion, - _fflag_Wno_maybe_uninitialized, - _fflag_Wno_unused_dummy_argument, - _fflag_Wno_unused_label, - _fflag_Wno_unused_variable, - _fflag_Wno_tabs, -) - -# Intel Fortran (ifort) does not run the preprocessor by default, if Fortran -# code uses preprocessor statements, add this compile flag to it. - -# Gfortran does run the preprocessor for .F files, and PROPACK is the only -# component which needs the preprocessor (unless we need symbol renaming for -# blas_symbol_suffix). -_fflag_preprocess = [] -_gfortran_preprocess = ['-cpp', '-ffree-line-length-none', '-ffixed-line-length-none'] -if ff.has_multi_arguments(_gfortran_preprocess) - _fflag_preprocess = _gfortran_preprocess -else - _fflag_preprocess = ff.first_supported_argument(['-fpp', '/fpp', '-cpp']) -endif - -_fflag_ilp64 = [] f2py_ilp64_opts = [] if use_ilp64 - # Gfortran and Clang use `-fdefault-integer-8` to switch to 64-bit integers by - # default, all other known compilers use `-i8` - _fflag_ilp64 = ff.first_supported_argument(['-fdefault-integer-8', '-i8']) - # Write out a mapping file for f2py for defaulting to ILP64 conf_data = configuration_data() if cc.sizeof('long') == 8 @@ -715,7 +669,6 @@ compilers = { 'C': cc, 'CPP': cpp, 'CYTHON': meson.get_compiler('cython'), - 'FORTRAN': meson.get_compiler('fortran') } machines = { @@ -845,6 +798,5 @@ subdir('differentiate') subdir('signal') subdir('interpolate') subdir('ndimage') -subdir('odr') subdir('datasets') subdir('misc') diff --git a/scipy/odr/__init__.py b/scipy/odr/__init__.py deleted file mode 100644 index 1e3c3addc07b..000000000000 --- a/scipy/odr/__init__.py +++ /dev/null @@ -1,177 +0,0 @@ -""" -================================================= -Orthogonal distance regression (:mod:`scipy.odr`) -================================================= - -.. currentmodule:: scipy.odr - -.. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - The following example shows a brief comparison of the APIs:: - - import numpy as np - import scipy.odr - import odrpack - - # Classic "Pearson data" that motivates ODR. - # Errors are in both variables, and if you don't account for this, - # doing a linear fit of X vs. Y or Y vs. X will give you quite - # different results. - p_x = np.array([0., .9, 1.8, 2.6, 3.3, 4.4, 5.2, 6.1, 6.5, 7.4]) - p_y = np.array([5.9, 5.4, 4.4, 4.6, 3.5, 3.7, 2.8, 2.8, 2.4, 1.5]) - p_sx = np.array([.03, .03, .04, .035, .07, .11, .13, .22, .74, 1.]) - p_sy = np.array([1., .74, .5, .35, .22, .22, .12, .12, .1, .04]) - - # Old-style - # The RealData class takes care of details like turning - # standard-deviation error bars into weights. - p_dat = scipy.odr.RealData(p_x, p_y, sx=p_sx, sy=p_sy) - # Note, parameters come before `x` in scipy.odr - p_mod = scipy.odr.Model(lambda beta, x: beta[0] + beta[1]*x) - p_odr = scipy.odr.ODR(p_dat, p_mod, beta0=[1., 1.]) - old_out = p_odr.run() - - # New-style - # Parameters come after data, in the new API. - # We must convert the error bars into weights ourselves. - new_out = odrpack.odr_fit(lambda x, beta: beta[0] + beta[1] * x, - p_x, p_y, beta0=np.array([1.0, 1.0]), - weight_x=p_sx**-2, weight_y=p_sy**-2) - - assert np.isclose(old_out.beta, new_out.beta).all() - - -Package Content -=============== - -.. autosummary:: - :toctree: generated/ - - Data -- The data to fit. - RealData -- Data with weights as actual std. dev.s and/or covariances. - Model -- Stores information about the function to be fit. - ODR -- Gathers all info & manages the main fitting routine. - Output -- Result from the fit. - odr -- Low-level function for ODR. - - OdrWarning -- Warning about potential problems when running ODR. - OdrError -- Error exception. - OdrStop -- Stop exception. - - polynomial -- Factory function for a general polynomial model. - exponential -- Exponential model - multilinear -- Arbitrary-dimensional linear model - unilinear -- Univariate linear model - quadratic -- Quadratic model - -Usage information -================= - -Introduction ------------- - -Why Orthogonal Distance Regression (ODR)? Sometimes one has -measurement errors in the explanatory (a.k.a., "independent") -variable(s), not just the response (a.k.a., "dependent") variable(s). -Ordinary Least Squares (OLS) fitting procedures treat the data for -explanatory variables as fixed, i.e., not subject to error of any kind. -Furthermore, OLS procedures require that the response variables be an -explicit function of the explanatory variables; sometimes making the -equation explicit is impractical and/or introduces errors. ODR can -handle both of these cases with ease, and can even reduce to the OLS -case if that is sufficient for the problem. - -ODRPACK is a FORTRAN-77 library for performing ODR with possibly -non-linear fitting functions. It uses a modified trust-region -Levenberg-Marquardt-type algorithm [1]_ to estimate the function -parameters. The fitting functions are provided by Python functions -operating on NumPy arrays. The required derivatives may be provided -by Python functions as well, or may be estimated numerically. ODRPACK -can do explicit or implicit ODR fits, or it can do OLS. Input and -output variables may be multidimensional. Weights can be provided to -account for different variances of the observations, and even -covariances between dimensions of the variables. - -The `scipy.odr` package offers an object-oriented interface to -ODRPACK, in addition to the low-level `odr` function. - -Additional background information about ODRPACK can be found in the -`ODRPACK User's Guide -`_, reading -which is recommended. - -Basic usage ------------ - -1. Define the function you want to fit against.:: - - def f(B, x): - '''Linear function y = m*x + b''' - # B is a vector of the parameters. - # x is an array of the current x values. - # x is in the same format as the x passed to Data or RealData. - # - # Return an array in the same format as y passed to Data or RealData. - return B[0]*x + B[1] - -2. Create a Model.:: - - linear = Model(f) - -3. Create a Data or RealData instance.:: - - mydata = Data(x, y, wd=1./power(sx,2), we=1./power(sy,2)) - - or, when the actual covariances are known:: - - mydata = RealData(x, y, sx=sx, sy=sy) - -4. Instantiate ODR with your data, model and initial parameter estimate.:: - - myodr = ODR(mydata, linear, beta0=[1., 2.]) - -5. Run the fit.:: - - myoutput = myodr.run() - -6. Examine output.:: - - myoutput.pprint() - - -References ----------- -.. [1] P. T. Boggs and J. E. Rogers, "Orthogonal Distance Regression," - in "Statistical analysis of measurement error models and - applications: proceedings of the AMS-IMS-SIAM joint summer research - conference held June 10-16, 1989," Contemporary Mathematics, - vol. 112, pg. 186, 1990. - -""" -# version: 0.7 -# author: Robert Kern -# date: 2006-09-21 - -from ._odrpack import * -from ._models import * -from . import _add_newdocs - -# Deprecated namespaces, to be removed in v2.0.0 -from . import models, odrpack - -__all__ = [s for s in dir() - if not (s.startswith('_') or s in ('odr_stop', 'odr_error'))] - -import warnings -msg = ("`scipy.odr` is deprecated as of version 1.17.0 and will be removed in " - "SciPy 1.19.0. Please use `https://pypi.org/project/odrpack/` instead.") -warnings.warn(msg, DeprecationWarning, stacklevel=2) -del warnings - - -from scipy._lib._testutils import PytestTester -test = PytestTester(__name__) -del PytestTester diff --git a/scipy/odr/__odrpack.c b/scipy/odr/__odrpack.c deleted file mode 100644 index f86a65fdf698..000000000000 --- a/scipy/odr/__odrpack.c +++ /dev/null @@ -1,1305 +0,0 @@ -/* Anti-Copyright - * - * I hereby release this code into the PUBLIC DOMAIN AS IS. There is no - * support, warranty, or guarantee. I will gladly accept comments, bug - * reports, and patches, however. - * - * Robert Kern - * kern@caltech.edu - * - */ - -#define PY_SSIZE_T_CLEAN -#include "odrpack.h" - - -void F_FUNC(dodrc,DODRC)(void (*fcn)(F_INT *n, F_INT *m, F_INT *np, F_INT *nq, F_INT *ldn, F_INT *ldm, - F_INT *ldnp, double *beta, double *xplusd, F_INT *ifixb, F_INT *ifixx, - F_INT *ldifx, F_INT *ideval, double *f, double *fjacb, double *fjacd, - F_INT *istop), - F_INT *n, F_INT *m, F_INT *np, F_INT *nq, double *beta, double *y, F_INT *ldy, - double *x, F_INT *ldx, double *we, F_INT *ldwe, F_INT *ld2we, double *wd, - F_INT *ldwd, F_INT *ld2wd, F_INT *ifixb, F_INT *ifixx, F_INT *ldifx, F_INT *job, - F_INT *ndigit, double *taufac, double *sstol, double *partol, - F_INT *maxit, F_INT *iprF_INT, F_INT *lunerr, F_INT *lunrpt, double *stpb, - double *stpd, F_INT *ldstpd, double *sclb, double *scld, F_INT *ldscld, - double *work, F_INT *lwork, F_INT *iwork, F_INT *liwork, F_INT *info); -void F_FUNC(dwinf,DWINF)(F_INT *n, F_INT *m, F_INT *np, F_INT *nq, F_INT *ldwe, F_INT *ld2we, F_INT *isodr, - F_INT *delta, F_INT *eps, F_INT *xplus, F_INT *fn, F_INT *sd, F_INT *vcv, F_INT *rvar, - F_INT *wss, F_INT *wssde, F_INT *wssep, F_INT *rcond, F_INT *eta, F_INT *olmav, - F_INT *tau, F_INT *alpha, F_INT *actrs, F_INT *pnorm, F_INT *rnors, F_INT *prers, - F_INT *partl, F_INT *sstol, F_INT *taufc, F_INT *apsma, F_INT *betao, F_INT *betac, - F_INT *betas, F_INT *betan, F_INT *s, F_INT *ss, F_INT *ssf, F_INT *qraux, F_INT *u, - F_INT *fs, F_INT *fjacb, F_INT *we1, F_INT *diff, F_INT *delts, F_INT *deltn, - F_INT *t, F_INT *tt, F_INT *omega, F_INT *fjacd, F_INT *wrk1, F_INT *wrk2, - F_INT *wrk3, F_INT *wrk4, F_INT *wrk5, F_INT *wrk6, F_INT *wrk7, F_INT *lwkmn); -void F_FUNC(dluno,DLUNO)(F_INT *lun, char *fn, int fnlen); -void F_FUNC(dlunc,DLUNC)(F_INT *lun); - - - -/* callback to pass to DODRC; calls the Python function in the global structure |odr_global| */ -void fcn_callback(F_INT *n, F_INT *m, F_INT *np, F_INT *nq, F_INT *ldn, F_INT *ldm, - F_INT *ldnp, double *beta, double *xplusd, F_INT *ifixb, - F_INT *ifixx, F_INT *ldfix, F_INT *ideval, double *f, - double *fjacb, double *fjacd, F_INT *istop) -{ - PyObject *arg01, *arglist; - PyObject *result = NULL; - PyArrayObject *result_array = NULL; - PyArrayObject *pyXplusD; - void *beta_dst; - - if (*m != 1) - { - npy_intp dim2[2]; - dim2[0] = *m; - dim2[1] = *n; - pyXplusD = (PyArrayObject *) PyArray_SimpleNew(2, dim2, NPY_DOUBLE); - memcpy(PyArray_DATA(pyXplusD), (void *)xplusd, (*m) * (*n) * sizeof(double)); - } - else - { - npy_intp dim1[1]; - dim1[0] = *n; - pyXplusD = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - memcpy(PyArray_DATA(pyXplusD), (void *)xplusd, (*n) * sizeof(double)); - } - - arg01 = PyTuple_Pack(2, odr_global.pyBeta, (PyObject *) pyXplusD); - Py_DECREF(pyXplusD); - if (arg01 == NULL) { - return; - } - - if (odr_global.extra_args != NULL) - arglist = PySequence_Concat(arg01, odr_global.extra_args); - else - arglist = PySequence_Tuple(arg01); /* make a copy */ - Py_DECREF(arg01); - - *istop = 0; - - beta_dst = (PyArray_DATA((PyArrayObject *) odr_global.pyBeta)); - if (beta != beta_dst) { - memcpy(beta_dst, (void *)beta, (*np) * sizeof(double)); - } - - if ((*ideval % 10) >= 1) - { - /* compute f with odr_global.fcn */ - - if (odr_global.fcn == NULL) - { - /* we don't have a function to call */ - PYERR2(odr_error, "Function has not been initialized"); - } - - if ((result = PyObject_CallObject(odr_global.fcn, arglist)) == NULL) - { - if (PyErr_ExceptionMatches(odr_stop)) - { - /* stop, don't fail */ - *istop = 1; - - Py_DECREF(arglist); - return; - } - goto fail; - } - - if ((result_array = - (PyArrayObject *) PyArray_ContiguousFromObject(result, - NPY_DOUBLE, 0, - 2)) == NULL) - { - PYERR2(odr_error, - "Result from function call is not a proper array of floats."); - } - - memcpy((void *)f, PyArray_DATA(result_array), (*n) * (*nq) * sizeof(double)); - Py_DECREF(result_array); - } - - if (((*ideval) / 10) % 10 >= 1) - { - /* compute fjacb with odr_global.fjacb */ - - if (odr_global.fjacb == NULL) - { - /* we don't have a function to call */ - PYERR2(odr_error, "Function has not been initialized"); - } - - if ((result = PyObject_CallObject(odr_global.fjacb, arglist)) == NULL) - { - if (PyErr_ExceptionMatches(odr_stop)) - { - /* stop, don't fail */ - *istop = 1; - - Py_DECREF(arglist); - return; - } - goto fail; - } - - if ((result_array = - (PyArrayObject *) PyArray_ContiguousFromObject(result, - NPY_DOUBLE, 0, - 3)) == NULL) - { - PYERR2(odr_error, - "Result from function call is not a proper array of floats."); - } - - if (*nq != 1 && *np != 1) - { - /* result_array should be rank-3 */ - - if (PyArray_NDIM(result_array) != 3) - { - Py_DECREF(result_array); - PYERR2(odr_error, "Beta Jacobian is not rank-3"); - } - } - else if (*nq == 1) - { - /* result_array should be rank-2 */ - - if (PyArray_NDIM(result_array) != 2) - { - Py_DECREF(result_array); - PYERR2(odr_error, "Beta Jacobian is not rank-2"); - } - } - - memcpy((void *)fjacb, PyArray_DATA(result_array), - (*n) * (*nq) * (*np) * sizeof(double)); - Py_DECREF(result_array); - - } - - if (((*ideval) / 100) % 10 >= 1) - { - /* compute fjacd with odr_global.fjacd */ - - if (odr_global.fjacd == NULL) - { - /* we don't have a function to call */ - PYERR2(odr_error, "fjcad has not been initialized"); - } - - if ((result = PyObject_CallObject(odr_global.fjacd, arglist)) == NULL) - { - if (PyErr_ExceptionMatches(odr_stop)) - { - /* stop, don't fail */ - *istop = 1; - - Py_DECREF(arglist); - return; - } - goto fail; - } - - if ((result_array = - (PyArrayObject *) PyArray_ContiguousFromObject(result, - NPY_DOUBLE, 0, - 3)) == NULL) - { - PYERR2(odr_error, - "Result from function call is not a proper array of floats."); - } - - if (*nq != 1 && *m != 1) - { - /* result_array should be rank-3 */ - - if (PyArray_NDIM(result_array) != 3) - { - Py_DECREF(result_array); - PYERR2(odr_error, "xplusd Jacobian is not rank-3"); - } - } - else if (*nq == 1 && *m != 1) - { - /* result_array should be rank-2 */ - - if (PyArray_NDIM(result_array) != 2) - { - Py_DECREF(result_array); - PYERR2(odr_error, "xplusd Jacobian is not rank-2"); - } - } - else if (*nq == 1 && *m == 1) - { - /* result_array should be rank-1 */ - - if (PyArray_NDIM(result_array) != 1) - { - Py_DECREF(result_array); - PYERR2(odr_error, "xplusd Jacobian is not rank-1"); - } - } - - memcpy((void *)fjacd, PyArray_DATA(result_array), - (*n) * (*nq) * (*m) * sizeof(double)); - Py_DECREF(result_array); - } - - Py_DECREF(result); - Py_DECREF(arglist); - - return; - -fail: - Py_XDECREF(result); - Py_XDECREF(arglist); - *istop = -1; - return; -} - - -/* generates Python output from the raw output from DODRC */ -PyObject *gen_output(F_INT n, F_INT m, F_INT np, F_INT nq, F_INT ldwe, F_INT ld2we, - PyArrayObject * beta, PyArrayObject * work, - PyArrayObject * iwork, F_INT isodr, F_INT info, - int full_output) -{ - PyArrayObject *sd_beta, *cov_beta; - - F_INT delta, eps, xplus, fn, sd, vcv, rvar, wss, wssde, wssep, rcond; - F_INT eta, olmav, tau, alpha, actrs, pnorm, rnors, prers, partl, sstol; - F_INT taufc, apsma, betao, betac, betas, betan, s, ss, ssf, qraux, u; - F_INT fs, fjacb, we1, diff, delts, deltn, t, tt, omega, fjacd; - F_INT wrk1, wrk2, wrk3, wrk4, wrk5, wrk6, wrk7, lwkmn; - - PyObject *retobj; - - npy_intp dim1[1], dim2[2]; - - if (info == 50005) { - /* fatal error in fcn call; return NULL to propagate the exception */ - - return NULL; - } - - lwkmn = PyArray_DIMS(work)[0]; - - F_FUNC(dwinf,DWINF)(&n, &m, &np, &nq, &ldwe, &ld2we, &isodr, - &delta, &eps, &xplus, &fn, &sd, &vcv, &rvar, &wss, &wssde, - &wssep, &rcond, &eta, &olmav, &tau, &alpha, &actrs, &pnorm, - &rnors, &prers, &partl, &sstol, &taufc, &apsma, &betao, &betac, - &betas, &betan, &s, &ss, &ssf, &qraux, &u, &fs, &fjacb, &we1, - &diff, &delts, &deltn, &t, &tt, &omega, &fjacd, &wrk1, &wrk2, - &wrk3, &wrk4, &wrk5, &wrk6, &wrk7, &lwkmn); - - /* convert FORTRAN indices to C indices */ - delta--; - eps--; - xplus--; - fn--; - sd--; - vcv--; - rvar--; - wss--; - wssde--; - wssep--; - rcond--; - eta--; - olmav--; - tau--; - alpha--; - actrs--; - pnorm--; - rnors--; - prers--; - partl--; - sstol--; - taufc--; - apsma--; - betao--; - betac--; - betas--; - betan--; - s--; - ss--; - ssf--; - qraux--; - u--; - fs--; - fjacb--; - we1--; - diff--; - delts--; - deltn--; - t--; - tt--; - omega--; - fjacd--; - wrk1--; - wrk2--; - wrk3--; - wrk4--; - wrk5--; - wrk6--; - wrk7--; - - dim1[0] = PyArray_DIMS(beta)[0]; - sd_beta = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - dim2[0] = PyArray_DIMS(beta)[0]; - dim2[1] = PyArray_DIMS(beta)[0]; - cov_beta = (PyArrayObject *) PyArray_SimpleNew(2, dim2, NPY_DOUBLE); - - memcpy(PyArray_DATA(sd_beta), (void *)((double *)(PyArray_DATA(work)) + sd), - np * sizeof(double)); - memcpy(PyArray_DATA(cov_beta), (void *)((double *)(PyArray_DATA(work)) + vcv), - np * np * sizeof(double)); - - if (!full_output) - { - retobj = Py_BuildValue("OOO", PyArray_Return(beta), - PyArray_Return(sd_beta), - PyArray_Return(cov_beta)); - Py_DECREF((PyObject *) sd_beta); - Py_DECREF((PyObject *) cov_beta); - - return retobj; - } - else - { - PyArrayObject *deltaA, *epsA, *xplusA, *fnA; - double res_var, sum_square, sum_square_delta, sum_square_eps; - double inv_condnum, rel_error; - PyObject *work_ind; - - work_ind = - Py_BuildValue - (("{s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT ",s:" F_INT_PYFMT - ",s:" F_INT_PYFMT "}"), - "delta", delta, "eps", eps, "xplus", xplus, "fn", fn, "sd", sd, "vcv", - vcv, "rvar", rvar, "wss", wss, "wssde", wssde, "wssep", wssep, - "rcond", rcond, "eta", eta, "olmav", olmav, "tau", tau, "alpha", - alpha, "actrs", actrs, "pnorm", pnorm, "rnors", rnors, "prers", - prers, "partl", partl, "sstol", sstol, "taufc", taufc, "apsma", - apsma, "betao", betao, "betac", betac, "betas", betas, "betan", - betan, "s", s, "ss", ss, "ssf", ssf, "qraux", qraux, "u", u, "fs", - fs, "fjacb", fjacb, "we1", we1, "diff", diff, "delts", delts, - "deltn", deltn, "t", t, "tt", tt, "omega", omega, "fjacd", fjacd, - "wrk1", wrk1, "wrk2", wrk2, "wrk3", wrk3, "wrk4", wrk4, "wrk5", wrk5, - "wrk6", wrk6, "wrk7", wrk7); - - if (m == 1) - { - dim1[0] = n; - deltaA = - (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - xplusA = - (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - } - else - { - dim2[0] = m; - dim2[1] = n; - deltaA = - (PyArrayObject *) PyArray_SimpleNew(2, dim2, NPY_DOUBLE); - xplusA = - (PyArrayObject *) PyArray_SimpleNew(2, dim2, NPY_DOUBLE); - } - - if (nq == 1) - { - dim1[0] = n; - epsA = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - fnA = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - } - else - { - dim2[0] = nq; - dim2[1] = n; - epsA = (PyArrayObject *) PyArray_SimpleNew(2, dim2, NPY_DOUBLE); - fnA = (PyArrayObject *) PyArray_SimpleNew(2, dim2, NPY_DOUBLE); - } - - memcpy(PyArray_DATA(deltaA), (void *)((double *)(PyArray_DATA(work)) + delta), - m * n * sizeof(double)); - memcpy(PyArray_DATA(epsA), (void *)((double *)(PyArray_DATA(work)) + eps), - nq * n * sizeof(double)); - memcpy(PyArray_DATA(xplusA), (void *)((double *)(PyArray_DATA(work)) + xplus), - m * n * sizeof(double)); - memcpy(PyArray_DATA(fnA), (void *)((double *)(PyArray_DATA(work)) + fn), - nq * n * sizeof(double)); - - res_var = *((double *)(PyArray_DATA(work)) + rvar); - sum_square = *((double *)(PyArray_DATA(work)) + wss); - sum_square_delta = *((double *)(PyArray_DATA(work)) + wssde); - sum_square_eps = *((double *)(PyArray_DATA(work)) + wssep); - inv_condnum = *((double *)(PyArray_DATA(work)) + rcond); - rel_error = *((double *)(PyArray_DATA(work)) + eta); - - retobj = - Py_BuildValue - (("OOO{s:O,s:O,s:O,s:O,s:d,s:d,s:d,s:d,s:d,s:d,s:O,s:O,s:O,s:" F_INT_PYFMT "}"), - PyArray_Return(beta), PyArray_Return(sd_beta), - PyArray_Return(cov_beta), "delta", PyArray_Return(deltaA), "eps", - PyArray_Return(epsA), "xplus", PyArray_Return(xplusA), "y", - PyArray_Return(fnA), "res_var", res_var, "sum_square", sum_square, - "sum_square_delta", sum_square_delta, "sum_square_eps", - sum_square_eps, "inv_condnum", inv_condnum, "rel_error", rel_error, - "work", PyArray_Return(work), "work_ind", work_ind, "iwork", - PyArray_Return(iwork), "info", info); - Py_DECREF((PyObject *) sd_beta); - Py_DECREF((PyObject *) cov_beta); - Py_DECREF((PyObject *) deltaA); - Py_DECREF((PyObject *) epsA); - Py_DECREF((PyObject *) xplusA); - Py_DECREF((PyObject *) fnA); - Py_DECREF((PyObject *) work_ind); - - return retobj; - } -} - -PyObject *odr(PyObject * self, PyObject * args, PyObject * kwds) -{ - PyObject *fcn, *initbeta, *py, *px, *pwe = NULL, *pwd = NULL, *fjacb = NULL; - PyObject *fjacd = NULL, *pifixb = NULL, *pifixx = NULL; - PyObject *pstpb = NULL, *pstpd = NULL, *psclb = NULL, *pscld = NULL; - PyObject *pwork = NULL, *piwork = NULL, *extra_args = NULL; - F_INT job = 0, ndigit = 0, maxit = -1, iprint = 0; - int full_output = 0; - double taufac = 0.0, sstol = -1.0, partol = -1.0; - char *errfile = NULL, *rptfile = NULL; - Py_ssize_t lerrfile = 0, lrptfile = 0; - PyArrayObject *beta = NULL, *y = NULL, *x = NULL, *we = NULL, *wd = NULL; - PyArrayObject *ifixb = NULL, *ifixx = NULL; - PyArrayObject *stpb = NULL, *stpd = NULL, *sclb = NULL, *scld = NULL; - PyArrayObject *work = NULL, *iwork = NULL; - F_INT n, m, np, nq, ldy, ldx, ldwe, ld2we, ldwd, ld2wd, ldifx; - F_INT lunerr = -1, lunrpt = -1, ldstpd, ldscld, lwork, liwork, info = 0; - static char *kw_list[] = { "fcn", "initbeta", "y", "x", "we", "wd", "fjacb", - "fjacd", "extra_args", "ifixb", "ifixx", "job", "iprint", "errfile", - "rptfile", "ndigit", "taufac", "sstol", "partol", - "maxit", "stpb", "stpd", "sclb", "scld", "work", - "iwork", "full_output", NULL - }; - F_INT isodr = 1; - PyObject *result; - npy_intp dim1[1], dim2[2], dim3[3]; - F_INT implicit; /* flag for implicit model */ - - - if (kwds == NULL) - { - if (!PyArg_ParseTuple(args, ("OOOO|OOOOOOO" F_INT_PYFMT F_INT_PYFMT - "z#z#" F_INT_PYFMT "ddd" F_INT_PYFMT - "OOOOOOi:odr"), - &fcn, &initbeta, &py, &px, &pwe, &pwd, - &fjacb, &fjacd, &extra_args, &pifixb, &pifixx, - &job, &iprint, &errfile, &lerrfile, &rptfile, - &lrptfile, &ndigit, &taufac, &sstol, &partol, - &maxit, &pstpb, &pstpd, &psclb, &pscld, &pwork, - &piwork, &full_output)) - { - return NULL; - } - } - else - { - if (!PyArg_ParseTupleAndKeywords(args, kwds, - ("OOOO|OOOOOOO" F_INT_PYFMT "" F_INT_PYFMT - "z#z#" F_INT_PYFMT "ddd" F_INT_PYFMT - "OOOOOOi:odr"), - kw_list, &fcn, &initbeta, &py, &px, - &pwe, &pwd, &fjacb, &fjacd, - &extra_args, &pifixb, &pifixx, &job, - &iprint, &errfile, &lerrfile, &rptfile, - &lrptfile, &ndigit, &taufac, &sstol, - &partol, &maxit, &pstpb, &pstpd, - &psclb, &pscld, &pwork, &piwork, - &full_output)) - { - return NULL; - } - } - - /* Check the validity of all arguments */ - - if (!PyCallable_Check(fcn)) - { - PYERR(PyExc_TypeError, "fcn must be callable"); - } - if (!PySequence_Check(initbeta)) - { - PYERR(PyExc_TypeError, "initbeta must be a sequence"); - } - if (!PySequence_Check(py) && !PyNumber_Check(py)) - { - PYERR(PyExc_TypeError, - "y must be a sequence or integer (if model is implicit)"); - } - if (!PySequence_Check(px)) - { - PYERR(PyExc_TypeError, "x must be a sequence"); - } - if (pwe != NULL && !PySequence_Check(pwe) && !PyNumber_Check(pwe)) - { - PYERR(PyExc_TypeError, "we must be a sequence or a number"); - } - if (pwd != NULL && !PySequence_Check(pwd) && !PyNumber_Check(pwd)) - { - PYERR(PyExc_TypeError, "wd must be a sequence or a number"); - } - if (fjacb != NULL && !PyCallable_Check(fjacb)) - { - PYERR(PyExc_TypeError, "fjacb must be callable"); - } - if (fjacd != NULL && !PyCallable_Check(fjacd)) - { - PYERR(PyExc_TypeError, "fjacd must be callable"); - } - if (extra_args != NULL && !PySequence_Check(extra_args)) - { - PYERR(PyExc_TypeError, "extra_args must be a sequence"); - } - if (pifixx != NULL && !PySequence_Check(pifixx)) - { - PYERR(PyExc_TypeError, "ifixx must be a sequence"); - } - if (pifixb != NULL && !PySequence_Check(pifixb)) - { - PYERR(PyExc_TypeError, "ifixb must be a sequence"); - } - if (pstpb != NULL && !PySequence_Check(pstpb)) - { - PYERR(PyExc_TypeError, "stpb must be a sequence"); - } - if (pstpd != NULL && !PySequence_Check(pstpd)) - { - PYERR(PyExc_TypeError, "stpd must be a sequence"); - } - if (psclb != NULL && !PySequence_Check(psclb)) - { - PYERR(PyExc_TypeError, "sclb must be a sequence"); - } - if (pscld != NULL && !PySequence_Check(pscld)) - { - PYERR(PyExc_TypeError, "scld must be a sequence"); - } - if (pwork != NULL && !PyArray_Check(pwork)) - { - PYERR(PyExc_TypeError, "work must be an array"); - } - if (piwork != NULL && !PyArray_Check(piwork)) - { - PYERR(PyExc_TypeError, "iwork must be an array"); - } - - /* start processing the arguments and check for errors on the way */ - - /* check for implicit model */ - - implicit = (job % 10 == 1); - - if (!implicit) - { - if ((y = - (PyArrayObject *) PyArray_CopyFromObject(py, NPY_DOUBLE, 1, - 2)) == NULL) - { - PYERR(PyExc_ValueError, - "y could not be made into a suitable array"); - } - n = PyArray_DIMS(y)[PyArray_NDIM(y) - 1]; /* pick the last dimension */ - if ((x = - (PyArrayObject *) PyArray_CopyFromObject(px, NPY_DOUBLE, 1, - 2)) == NULL) - { - PYERR(PyExc_ValueError, - "x could not be made into a suitable array"); - } - if (n != PyArray_DIMS(x)[PyArray_NDIM(x) - 1]) - { - PYERR(PyExc_ValueError, - "x and y don't have matching numbers of observations"); - } - if (PyArray_NDIM(y) == 1) - { - nq = 1; - } - else - { - nq = PyArray_DIMS(y)[0]; - } - - ldx = ldy = n; - } - else - { /* we *do* have an implicit model */ - ldy = 1; - nq = (F_INT)PyLong_AsLong(py); - dim1[0] = 1; - - /* initialize y to a dummy array; never referenced */ - y = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - - if ((x = - (PyArrayObject *) PyArray_CopyFromObject(px, NPY_DOUBLE, 1, - 2)) == NULL) - { - PYERR(PyExc_ValueError, - "x could not be made into a suitable array"); - } - - n = PyArray_DIMS(x)[PyArray_NDIM(x) - 1]; - ldx = n; - } - - if (PyArray_NDIM(x) == 1) - { - m = 1; - } - else - { - m = PyArray_DIMS(x)[0]; - } /* x, y */ - - if ((beta = - (PyArrayObject *) PyArray_CopyFromObject(initbeta, NPY_DOUBLE, 1, - 1)) == NULL) - { - PYERR(PyExc_ValueError, - "initbeta could not be made into a suitable array"); - } - np = PyArray_DIMS(beta)[0]; - - if (pwe == NULL) - { - ldwe = ld2we = 1; - dim1[0] = n; - we = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - ((double *)(PyArray_DATA(we)))[0] = -1.0; - } - else if (PyNumber_Check(pwe) && !PyArray_Check(pwe)) - { - /* we is a single weight, set the first value of we to -pwe */ - PyObject *tmp; - double val; - - tmp = PyNumber_Float(pwe); - if (tmp == NULL) - PYERR(PyExc_ValueError, "could not convert we to a suitable array"); - val = PyFloat_AsDouble(tmp); - Py_DECREF(tmp); - - dim3[0] = nq; - dim3[1] = 1; - dim3[2] = 1; - we = (PyArrayObject *) PyArray_SimpleNew(3, dim3, NPY_DOUBLE); - if (implicit) - { - ((double *)(PyArray_DATA(we)))[0] = val; - } - else - { - ((double *)(PyArray_DATA(we)))[0] = -val; - } - ldwe = ld2we = 1; - } - else if (PySequence_Check(pwe)) - { - /* we needs to be turned into an array */ - - if ((we = - (PyArrayObject *) PyArray_CopyFromObject(pwe, NPY_DOUBLE, 1, - 3)) == NULL) - { - PYERR(PyExc_ValueError, "could not convert we to a suitable array"); - } - - if (PyArray_NDIM(we) == 1 && nq == 1) - { - - ldwe = n; - ld2we = 1; - } - else if (PyArray_NDIM(we) == 1 && PyArray_DIMS(we)[0] == nq) - { - /* we is a rank-1 array with diagonal weightings to be broadcast - * to all observations */ - ldwe = 1; - ld2we = 1; - } - else if (PyArray_NDIM(we) == 3 && PyArray_DIMS(we)[0] == nq - && PyArray_DIMS(we)[1] == nq && PyArray_DIMS(we)[2] == 1) - { - /* we is a rank-3 array with the covariant weightings - to be broadcast to all observations */ - ldwe = 1; - ld2we = nq; - } - else if (PyArray_NDIM(we) == 2 && PyArray_DIMS(we)[0] == nq - && PyArray_DIMS(we)[1] == nq) - { - /* we is a rank-2 array with the full covariant weightings - to be broadcast to all observations */ - ldwe = 1; - ld2we = nq; - } - - else if (PyArray_NDIM(we) == 2 && PyArray_DIMS(we)[0] == nq - && PyArray_DIMS(we)[1] == n) - { - /* we is a rank-2 array with the diagonal elements of the - covariant weightings for each observation */ - ldwe = n; - ld2we = 1; - } - else if (PyArray_NDIM(we) == 3 && PyArray_DIMS(we)[0] == nq - && PyArray_DIMS(we)[1] == nq && PyArray_DIMS(we)[2] == n) - { - /* we is the full specification of the covariant weights - for each observation */ - ldwe = n; - ld2we = nq; - } - else - { - PYERR(PyExc_ValueError, "could not convert we to a suitable array"); - } - } /* we */ - - if (pwd == NULL) - { - ldwd = ld2wd = 1; - - dim1[0] = m; - wd = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - ((double *)(PyArray_DATA(wd)))[0] = -1.0; - } - else if (PyNumber_Check(pwd) && !PyArray_Check(pwd)) - { - /* wd is a single weight, set the first value of wd to -pwd */ - PyObject *tmp; - double val; - - tmp = PyNumber_Float(pwd); - if (tmp == NULL) - PYERR(PyExc_ValueError, "could not convert wd to a suitable array"); - val = PyFloat_AsDouble(tmp); - Py_DECREF(tmp); - - dim3[0] = 1; - dim3[1] = 1; - dim3[2] = m; - wd = (PyArrayObject *) PyArray_SimpleNew(3, dim3, NPY_DOUBLE); - ((double *)(PyArray_DATA(wd)))[0] = -val; - ldwd = ld2wd = 1; - } - else if (PySequence_Check(pwd)) - { - /* wd needs to be turned into an array */ - - if ((wd = - (PyArrayObject *) PyArray_CopyFromObject(pwd, NPY_DOUBLE, 1, - 3)) == NULL) - { - PYERR(PyExc_ValueError, "could not convert wd to a suitable array"); - } - - if (PyArray_NDIM(wd) == 1 && m == 1) - { - ldwd = n; - ld2wd = 1; - } - else if (PyArray_NDIM(wd) == 1 && PyArray_DIMS(wd)[0] == m) - { - /* wd is a rank-1 array with diagonal weightings to be broadcast - * to all observations */ - ldwd = 1; - ld2wd = 1; - } - - else if (PyArray_NDIM(wd) == 3 && PyArray_DIMS(wd)[0] == m - && PyArray_DIMS(wd)[1] == m && PyArray_DIMS(wd)[2] == 1) - { - /* wd is a rank-3 array with the covariant wdightings - to be broadcast to all observations */ - ldwd = 1; - ld2wd = m; - } - else if (PyArray_NDIM(wd) == 2 && PyArray_DIMS(wd)[0] == m - && PyArray_DIMS(wd)[1] == m) - { - /* wd is a rank-2 array with the full covariant weightings - to be broadcast to all observations */ - ldwd = 1; - ld2wd = m; - } - - else if (PyArray_NDIM(wd) == 2 && PyArray_DIMS(wd)[0] == m - && PyArray_DIMS(wd)[1] == n) - { - /* wd is a rank-2 array with the diagonal elements of the - covariant weightings for each observation */ - ldwd = n; - ld2wd = 1; - } - else if (PyArray_NDIM(wd) == 3 && PyArray_DIMS(wd)[0] == m - && PyArray_DIMS(wd)[1] == m && PyArray_DIMS(wd)[2] == n) - { - /* wd is the full specification of the covariant weights - for each observation */ - ldwd = n; - ld2wd = m; - } - else - { - PYERR(PyExc_ValueError, "could not convert wd to a suitable array"); - } - - } /* wd */ - - - if (pifixb == NULL) - { - dim1[0] = np; - ifixb = (PyArrayObject *) PyArray_SimpleNew(1, dim1, F_INT_NPY); - *(F_INT *)(PyArray_DATA(ifixb)) = -1; /* set first element negative */ - } - else - { - /* pifixb is a sequence as checked before */ - - if ((ifixb = - (PyArrayObject *) PyArray_CopyFromObject(pifixb, F_INT_NPY, 1, - 1)) == NULL) - { - PYERR(PyExc_ValueError, - "could not convert ifixb to a suitable array"); - } - - if (PyArray_DIMS(ifixb)[0] != np) - { - PYERR(PyExc_ValueError, - "could not convert ifixb to a suitable array"); - } - } /* ifixb */ - - if (pifixx == NULL) - { - dim2[0] = m; - dim2[1] = 1; - ifixx = (PyArrayObject *) PyArray_SimpleNew(2, dim2, F_INT_NPY); - *(F_INT *)(PyArray_DATA(ifixx)) = -1; /* set first element negative */ - ldifx = 1; - } - else - { - /* pifixx is a sequence as checked before */ - - if ((ifixx = - (PyArrayObject *) PyArray_CopyFromObject(pifixx, F_INT_NPY, 1, - 2)) == NULL) - { - PYERR(PyExc_ValueError, - "could not convert ifixx to a suitable array"); - } - - if (PyArray_NDIM(ifixx) == 1 && PyArray_DIMS(ifixx)[0] == m) - { - ldifx = 1; - } - else if (PyArray_NDIM(ifixx) == 1 && PyArray_DIMS(ifixx)[0] == n && m == 1) - { - ldifx = n; - } - else if (PyArray_NDIM(ifixx) == 2 && PyArray_DIMS(ifixx)[0] == m - && PyArray_DIMS(ifixx)[1] == n) - { - ldifx = n; - } - else - { - PYERR(PyExc_ValueError, - "could not convert ifixx to a suitable array"); - } - } /* ifixx */ - - if (errfile != NULL) - { - /* call FORTRAN's OPEN to open the file with a logical unit of 18 */ - lunerr = 18; - F_FUNC(dluno,DLUNO)(&lunerr, errfile, lerrfile); - } - - if (rptfile != NULL) - { - /* call FORTRAN's OPEN to open the file with a logical unit of 19 */ - lunrpt = 19; - F_FUNC(dluno,DLUNO)(&lunrpt, rptfile, lrptfile); - } - - if (pstpb == NULL) - { - dim1[0] = np; - stpb = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - *(double *)(PyArray_DATA(stpb)) = 0.0; - } - else /* pstpb is a sequence */ - { - if ((stpb = - (PyArrayObject *) PyArray_CopyFromObject(pstpb, NPY_DOUBLE, 1, - 1)) == NULL - || PyArray_DIMS(stpb)[0] != np) - { - PYERR(PyExc_ValueError, - "could not convert stpb to a suitable array"); - } - } /* stpb */ - - if (pstpd == NULL) - { - dim2[0] = 1; - dim2[1] = m; - stpd = (PyArrayObject *) PyArray_SimpleNew(2, dim2, NPY_DOUBLE); - *(double *)(PyArray_DATA(stpd)) = 0.0; - ldstpd = 1; - } - else - { - if ((stpd = - (PyArrayObject *) PyArray_CopyFromObject(pstpd, NPY_DOUBLE, 1, - 2)) == NULL) - { - PYERR(PyExc_ValueError, - "could not convert stpb to a suitable array"); - } - - if (PyArray_NDIM(stpd) == 1 && PyArray_DIMS(stpd)[0] == m) - { - ldstpd = 1; - } - else if (PyArray_NDIM(stpd) == 1 && PyArray_DIMS(stpd)[0] == n && m == 1) - { - ldstpd = n; - } - else if (PyArray_NDIM(stpd) == 2 && PyArray_DIMS(stpd)[0] == n && - PyArray_DIMS(stpd)[1] == m) - { - ldstpd = n; - } - } /* stpd */ - - if (psclb == NULL) - { - dim1[0] = np; - sclb = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - *(double *)(PyArray_DATA(sclb)) = 0.0; - } - else /* psclb is a sequence */ - { - if ((sclb = - (PyArrayObject *) PyArray_CopyFromObject(psclb, NPY_DOUBLE, 1, - 1)) == NULL - || PyArray_DIMS(sclb)[0] != np) - { - PYERR(PyExc_ValueError, - "could not convert sclb to a suitable array"); - } - } /* sclb */ - - if (pscld == NULL) - { - dim2[0] = 1; - dim2[1] = n; - scld = (PyArrayObject *) PyArray_SimpleNew(2, dim2, NPY_DOUBLE); - *(double *)(PyArray_DATA(scld)) = 0.0; - ldscld = 1; - } - else - { - if ((scld = - (PyArrayObject *) PyArray_CopyFromObject(pscld, NPY_DOUBLE, 1, - 2)) == NULL) - { - PYERR(PyExc_ValueError, - "could not convert stpb to a suitable array"); - } - - if (PyArray_NDIM(scld) == 1 && PyArray_DIMS(scld)[0] == m) - { - ldscld = 1; - } - else if (PyArray_NDIM(scld) == 1 && PyArray_DIMS(scld)[0] == n && m == 1) - { - ldscld = n; - } - else if (PyArray_NDIM(scld) == 2 && PyArray_DIMS(scld)[0] == n && - PyArray_DIMS(scld)[1] == m) - { - ldscld = n; - } - } /* scld */ - - if (job % 10 < 2) - { - /* ODR, not OLS */ - - lwork = - 18 + 11 * np + np * np + m + m * m + 4 * n * nq + 6 * n * m + - 2 * n * nq * np + 2 * n * nq * m + nq * nq + 5 * nq + nq * (np + m) + - ldwe * ld2we * nq; - - isodr = 1; - } - else - { - /* OLS, not ODR */ - - lwork = - 18 + 11 * np + np * np + m + m * m + 4 * n * nq + 2 * n * m + - 2 * n * nq * np + 5 * nq + nq * (np + m) + ldwe * ld2we * nq; - - isodr = 0; - } - - liwork = 20 + np + nq * (np + m); - - if ((job / 10000) % 10 >= 1) - { - /* fit is a restart, make sure work and iwork are input */ - - if (pwork == NULL || piwork == NULL) - { - PYERR(PyExc_ValueError, - "need to input work and iwork arrays to restart"); - } - } - - if ((job / 1000) % 10 >= 1) - { - /* delta should be supplied, make sure the user does */ - - if (pwork == NULL) - { - PYERR(PyExc_ValueError, - "need to input work array for delta initialization"); - } - } - - if (pwork != NULL) - { - if ((work = - (PyArrayObject *) PyArray_CopyFromObject(pwork, NPY_DOUBLE, 1, - 1)) == NULL) - { - PYERR(PyExc_ValueError, - "could not convert work to a suitable array"); - } - if (PyArray_DIMS(work)[0] < lwork) - { - printf("%lld %lld\n", (long long)PyArray_DIMS(work)[0], (long long)lwork); - PYERR(PyExc_ValueError, "work is too small"); - } - } - else - { - /* initialize our own work array */ - dim1[0] = lwork; - work = (PyArrayObject *) PyArray_SimpleNew(1, dim1, NPY_DOUBLE); - } /* work */ - - if (piwork != NULL) - { - if ((iwork = - (PyArrayObject *) PyArray_CopyFromObject(piwork, F_INT_NPY, 1, - 1)) == NULL) - { - PYERR(PyExc_ValueError, - "could not convert iwork to a suitable array"); - } - - if (PyArray_DIMS(iwork)[0] < liwork) - { - PYERR(PyExc_ValueError, "iwork is too small"); - } - } - else - { - /* initialize our own iwork array */ - dim1[0] = liwork; - iwork = (PyArrayObject *) PyArray_SimpleNew(1, dim1, F_INT_NPY); - } /* iwork */ - - /* check if what JOB requests can be done with what the user has - input into the function */ - - if ((job / 10) % 10 >= 2) - { - /* derivatives are supposed to be supplied */ - - if (fjacb == NULL || fjacd == NULL) - { - PYERR(PyExc_ValueError, - "need fjacb and fjacd to calculate derivatives"); - } - } - - /* setup the global data for the callback */ - odr_global.fcn = fcn; - Py_INCREF(fcn); - odr_global.fjacb = fjacb; - Py_XINCREF(fjacb); - odr_global.fjacd = fjacd; - Py_XINCREF(fjacd); - odr_global.pyBeta = (PyObject *) beta; - Py_INCREF(beta); - odr_global.extra_args = extra_args; - Py_XINCREF(extra_args); - /* now call DODRC */ - F_FUNC(dodrc,DODRC)(fcn_callback, &n, &m, &np, &nq, (double *)(PyArray_DATA(beta)), - (double *)(PyArray_DATA(y)), &ldy, (double *)(PyArray_DATA(x)), &ldx, - (double *)(PyArray_DATA(we)), &ldwe, &ld2we, - (double *)(PyArray_DATA(wd)), &ldwd, &ld2wd, - (F_INT *)(PyArray_DATA(ifixb)), (F_INT *)(PyArray_DATA(ifixx)), &ldifx, - &job, &ndigit, &taufac, &sstol, &partol, &maxit, - &iprint, &lunerr, &lunrpt, - (double *)(PyArray_DATA(stpb)), (double *)(PyArray_DATA(stpd)), &ldstpd, - (double *)(PyArray_DATA(sclb)), (double *)(PyArray_DATA(scld)), &ldscld, - (double *)(PyArray_DATA(work)), &lwork, (F_INT *)(PyArray_DATA(iwork)), &liwork, - &info); - - result = gen_output(n, m, np, nq, ldwe, ld2we, - beta, work, iwork, isodr, info, full_output); - - if (result == NULL) - PYERR(PyExc_RuntimeError, "could not generate output"); - - if (lunerr != -1) - { - F_FUNC(dlunc,DLUNC)(&lunerr); - } - if (lunrpt != -1) - { - F_FUNC(dlunc,DLUNC)(&lunrpt); - } - - Py_DECREF(odr_global.fcn); - Py_XDECREF(odr_global.fjacb); - Py_XDECREF(odr_global.fjacd); - Py_DECREF(odr_global.pyBeta); - Py_XDECREF(odr_global.extra_args); - - odr_global.fcn = odr_global.fjacb = odr_global.fjacd = odr_global.pyBeta = - odr_global.extra_args = NULL; - - Py_DECREF(beta); - Py_DECREF(y); - Py_DECREF(x); - Py_DECREF(we); - Py_DECREF(wd); - Py_DECREF(ifixb); - Py_DECREF(ifixx); - Py_DECREF(stpb); - Py_DECREF(stpd); - Py_DECREF(sclb); - Py_DECREF(scld); - Py_DECREF(work); - Py_DECREF(iwork); - - return result; - -fail: - - - if (lunerr != -1) - { - F_FUNC(dlunc,DLUNC)(&lunerr); - } - if (lunrpt != -1) - { - F_FUNC(dlunc,DLUNC)(&lunrpt); - } - - Py_XDECREF(beta); - Py_XDECREF(y); - Py_XDECREF(x); - Py_XDECREF(we); - Py_XDECREF(wd); - Py_XDECREF(ifixb); - Py_XDECREF(ifixx); - Py_XDECREF(stpb); - Py_XDECREF(stpd); - Py_XDECREF(sclb); - Py_XDECREF(scld); - Py_XDECREF(work); - Py_XDECREF(iwork); - - return NULL; -} - - -PyObject *set_exceptions(PyObject * self, PyObject * args, PyObject * kwds) -{ - PyObject *exc_error, *exc_stop; - - if (!PyArg_ParseTuple(args, "OO", &exc_error, &exc_stop)) - return NULL; - - Py_INCREF(exc_stop); - Py_INCREF(exc_error); - odr_stop = exc_stop; - odr_error = exc_error; - - Py_INCREF(Py_None); - return Py_None; -} - -static PyMethodDef methods[] = { - {"_set_exceptions", (PyCFunction) set_exceptions, METH_VARARGS, NULL}, - {"odr", (PyCFunction) odr, METH_VARARGS | METH_KEYWORDS, NULL}, - {NULL, NULL}, -}; - -static struct PyModuleDef moduledef = { - PyModuleDef_HEAD_INIT, - "_odrpack", - NULL, - -1, - methods, - NULL, - NULL, - NULL, - NULL -}; - -PyMODINIT_FUNC -PyInit___odrpack(void) -{ - PyObject *module; - - import_array(); - module = PyModule_Create(&moduledef); - if (module == NULL) { - return module; - } - -#if Py_GIL_DISABLED - PyUnstable_Module_SetGIL(module, Py_MOD_GIL_NOT_USED); -#endif - - return module; -} diff --git a/scipy/odr/_add_newdocs.py b/scipy/odr/_add_newdocs.py deleted file mode 100644 index 3961b7623e88..000000000000 --- a/scipy/odr/_add_newdocs.py +++ /dev/null @@ -1,39 +0,0 @@ -from numpy.lib import add_newdoc - -add_newdoc('scipy.odr', 'odr', - """ - odr(fcn, beta0, y, x, we=None, wd=None, fjacb=None, fjacd=None, extra_args=None, - ifixx=None, ifixb=None, job=0, iprint=0, errfile=None, rptfile=None, ndigit=0, - taufac=0.0, sstol=-1.0, partol=-1.0, maxit=-1, stpb=None, stpd=None, sclb=None, - scld=None, work=None, iwork=None, full_output=0) - - Low-level function for ODR. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - See Also - -------- - ODR : The ODR class gathers all information and coordinates the running of the - main fitting routine. - Model : The Model class stores information about the function you wish to fit. - Data : The data to fit. - RealData : Data with weights as actual std. dev.s and/or covariances. - - Notes - ----- - This is a function performing the same operation as the `ODR`, - `Model`, and `Data` classes together. The parameters of this - function are explained in the class documentation. - - """) - -add_newdoc('scipy.odr.__odrpack', '_set_exceptions', - """ - _set_exceptions(odr_error, odr_stop) - - Internal function: set exception classes. - - """) diff --git a/scipy/odr/_models.py b/scipy/odr/_models.py deleted file mode 100644 index 8e5e7314873a..000000000000 --- a/scipy/odr/_models.py +++ /dev/null @@ -1,333 +0,0 @@ -""" Collection of Model instances for use with the odrpack fitting package. -""" -import numpy as np -from scipy.odr._odrpack import Model - -__all__ = ['Model', 'exponential', 'multilinear', 'unilinear', 'quadratic', - 'polynomial'] - - -def _lin_fcn(B, x): - a, b = B[0], B[1:] - b = b.reshape((b.shape[0], 1)) - - return a + (x*b).sum(axis=0) - - -def _lin_fjb(B, x): - a = np.ones(x.shape[-1], float) - res = np.concatenate((a, x.ravel())) - return res.reshape((B.shape[-1], x.shape[-1])) - - -def _lin_fjd(B, x): - b = B[1:] - b = np.repeat(b, (x.shape[-1],)*b.shape[-1], axis=0) - return b.reshape(x.shape) - - -def _lin_est(data): - # Eh. The answer is analytical, so just return all ones. - # Don't return zeros since that will interfere with - # ODRPACK's auto-scaling procedures. - - if len(data.x.shape) == 2: - m = data.x.shape[0] - else: - m = 1 - - return np.ones((m + 1,), float) - - -def _poly_fcn(B, x, powers): - a, b = B[0], B[1:] - b = b.reshape((b.shape[0], 1)) - - return a + np.sum(b * np.power(x, powers), axis=0) - - -def _poly_fjacb(B, x, powers): - res = np.concatenate((np.ones(x.shape[-1], float), - np.power(x, powers).flat)) - return res.reshape((B.shape[-1], x.shape[-1])) - - -def _poly_fjacd(B, x, powers): - b = B[1:] - b = b.reshape((b.shape[0], 1)) - - b = b * powers - - return np.sum(b * np.power(x, powers-1), axis=0) - - -def _exp_fcn(B, x): - return B[0] + np.exp(B[1] * x) - - -def _exp_fjd(B, x): - return B[1] * np.exp(B[1] * x) - - -def _exp_fjb(B, x): - res = np.concatenate((np.ones(x.shape[-1], float), x * np.exp(B[1] * x))) - return res.reshape((2, x.shape[-1])) - - -def _exp_est(data): - # Eh. - return np.array([1., 1.]) - - -class _MultilinearModel(Model): - r""" - Arbitrary-dimensional linear model - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - - This model is defined by :math:`y=\beta_0 + \sum_{i=1}^m \beta_i x_i` - - Examples - -------- - We can calculate orthogonal distance regression with an arbitrary - dimensional linear model: - - >>> from scipy import odr - >>> import numpy as np - >>> x = np.linspace(0.0, 5.0) - >>> y = 10.0 + 5.0 * x - >>> data = odr.Data(x, y) - >>> odr_obj = odr.ODR(data, odr.multilinear) - >>> output = odr_obj.run() - >>> print(output.beta) - [10. 5.] - - """ - - def __init__(self): - super().__init__( - _lin_fcn, fjacb=_lin_fjb, fjacd=_lin_fjd, estimate=_lin_est, - meta={'name': 'Arbitrary-dimensional Linear', - 'equ': 'y = B_0 + Sum[i=1..m, B_i * x_i]', - 'TeXequ': r'$y=\beta_0 + \sum_{i=1}^m \beta_i x_i$'}) - - -multilinear = _MultilinearModel() - - -def polynomial(order): - """ - Factory function for a general polynomial model. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - Parameters - ---------- - order : int or sequence - If an integer, it becomes the order of the polynomial to fit. If - a sequence of numbers, then these are the explicit powers in the - polynomial. - A constant term (power 0) is always included, so don't include 0. - Thus, polynomial(n) is equivalent to polynomial(range(1, n+1)). - - Returns - ------- - polynomial : Model instance - Model instance. - - Examples - -------- - We can fit an input data using orthogonal distance regression (ODR) with - a polynomial model: - - >>> import numpy as np - >>> import matplotlib.pyplot as plt - >>> from scipy import odr - >>> x = np.linspace(0.0, 5.0) - >>> y = np.sin(x) - >>> poly_model = odr.polynomial(3) # using third order polynomial model - >>> data = odr.Data(x, y) - >>> odr_obj = odr.ODR(data, poly_model) - >>> output = odr_obj.run() # running ODR fitting - >>> poly = np.poly1d(output.beta[::-1]) - >>> poly_y = poly(x) - >>> plt.plot(x, y, label="input data") - >>> plt.plot(x, poly_y, label="polynomial ODR") - >>> plt.legend() - >>> plt.show() - - """ - - powers = np.asarray(order) - if powers.shape == (): - # Scalar. - powers = np.arange(1, powers + 1) - - powers = powers.reshape((len(powers), 1)) - len_beta = len(powers) + 1 - - def _poly_est(data, len_beta=len_beta): - # Eh. Ignore data and return all ones. - return np.ones((len_beta,), float) - - return Model(_poly_fcn, fjacd=_poly_fjacd, fjacb=_poly_fjacb, - estimate=_poly_est, extra_args=(powers,), - meta={'name': 'Sorta-general Polynomial', - 'equ': 'y = B_0 + Sum[i=1..%s, B_i * (x**i)]' % (len_beta-1), - 'TeXequ': r'$y=\beta_0 + \sum_{i=1}^{%s} \beta_i x^i$' % - (len_beta-1)}) - - -class _ExponentialModel(Model): - r""" - Exponential model - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - This model is defined by :math:`y=\beta_0 + e^{\beta_1 x}` - - Examples - -------- - We can calculate orthogonal distance regression with an exponential model: - - >>> from scipy import odr - >>> import numpy as np - >>> x = np.linspace(0.0, 5.0) - >>> y = -10.0 + np.exp(0.5*x) - >>> data = odr.Data(x, y) - >>> odr_obj = odr.ODR(data, odr.exponential) - >>> output = odr_obj.run() - >>> print(output.beta) - [-10. 0.5] - - """ - - def __init__(self): - super().__init__(_exp_fcn, fjacd=_exp_fjd, fjacb=_exp_fjb, - estimate=_exp_est, - meta={'name': 'Exponential', - 'equ': 'y= B_0 + exp(B_1 * x)', - 'TeXequ': r'$y=\beta_0 + e^{\beta_1 x}$'}) - - -exponential = _ExponentialModel() - - -def _unilin(B, x): - return x*B[0] + B[1] - - -def _unilin_fjd(B, x): - return np.ones(x.shape, float) * B[0] - - -def _unilin_fjb(B, x): - _ret = np.concatenate((x, np.ones(x.shape, float))) - return _ret.reshape((2,) + x.shape) - - -def _unilin_est(data): - return (1., 1.) - - -def _quadratic(B, x): - return x*(x*B[0] + B[1]) + B[2] - - -def _quad_fjd(B, x): - return 2*x*B[0] + B[1] - - -def _quad_fjb(B, x): - _ret = np.concatenate((x*x, x, np.ones(x.shape, float))) - return _ret.reshape((3,) + x.shape) - - -def _quad_est(data): - return (1.,1.,1.) - - -class _UnilinearModel(Model): - r""" - Univariate linear model - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - This model is defined by :math:`y = \beta_0 x + \beta_1` - - Examples - -------- - We can calculate orthogonal distance regression with an unilinear model: - - >>> from scipy import odr - >>> import numpy as np - >>> x = np.linspace(0.0, 5.0) - >>> y = 1.0 * x + 2.0 - >>> data = odr.Data(x, y) - >>> odr_obj = odr.ODR(data, odr.unilinear) - >>> output = odr_obj.run() - >>> print(output.beta) - [1. 2.] - - """ - - def __init__(self): - super().__init__(_unilin, fjacd=_unilin_fjd, fjacb=_unilin_fjb, - estimate=_unilin_est, - meta={'name': 'Univariate Linear', - 'equ': 'y = B_0 * x + B_1', - 'TeXequ': '$y = \\beta_0 x + \\beta_1$'}) - - -unilinear = _UnilinearModel() - - -class _QuadraticModel(Model): - r""" - Quadratic model - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - This model is defined by :math:`y = \beta_0 x^2 + \beta_1 x + \beta_2` - - Examples - -------- - We can calculate orthogonal distance regression with a quadratic model: - - >>> from scipy import odr - >>> import numpy as np - >>> x = np.linspace(0.0, 5.0) - >>> y = 1.0 * x ** 2 + 2.0 * x + 3.0 - >>> data = odr.Data(x, y) - >>> odr_obj = odr.ODR(data, odr.quadratic) - >>> output = odr_obj.run() - >>> print(output.beta) - [1. 2. 3.] - - """ - - def __init__(self): - super().__init__( - _quadratic, fjacd=_quad_fjd, fjacb=_quad_fjb, estimate=_quad_est, - meta={'name': 'Quadratic', - 'equ': 'y = B_0*x**2 + B_1*x + B_2', - 'TeXequ': '$y = \\beta_0 x^2 + \\beta_1 x + \\beta_2'}) - - -quadratic = _QuadraticModel() diff --git a/scipy/odr/_odrpack.py b/scipy/odr/_odrpack.py deleted file mode 100644 index 0f9af4a92f6f..000000000000 --- a/scipy/odr/_odrpack.py +++ /dev/null @@ -1,1200 +0,0 @@ -""" -Python wrappers for Orthogonal Distance Regression (ODRPACK). - -Notes -===== - -* Array formats -- FORTRAN stores its arrays in memory column first, i.e., an - array element A(i, j, k) will be next to A(i+1, j, k). In C and, consequently, - NumPy, arrays are stored row first: A[i, j, k] is next to A[i, j, k+1]. For - efficiency and convenience, the input and output arrays of the fitting - function (and its Jacobians) are passed to FORTRAN without transposition. - Therefore, where the ODRPACK documentation says that the X array is of shape - (N, M), it will be passed to the Python function as an array of shape (M, N). - If M==1, the 1-D case, then nothing matters; if M>1, then your - Python functions will be dealing with arrays that are indexed in reverse of - the ODRPACK documentation. No real issue, but watch out for your indexing of - the Jacobians: the i,jth elements (@f_i/@x_j) evaluated at the nth - observation will be returned as jacd[j, i, n]. Except for the Jacobians, it - really is easier to deal with x[0] and x[1] than x[:,0] and x[:,1]. Of course, - you can always use the transpose() function from SciPy explicitly. - -* Examples -- See the accompanying file test/test.py for examples of how to set - up fits of your own. Some are taken from the User's Guide; some are from - other sources. - -* Models -- Some common models are instantiated in the accompanying module - models.py . Contributions are welcome. - -Credits -======= - -* Thanks to Arnold Moene and Gerard Vermeulen for fixing some killer bugs. - -Robert Kern -robert.kern@gmail.com - -""" -import os -from threading import Lock - -import numpy as np -from warnings import warn -from scipy.odr import __odrpack - -__all__ = ['odr', 'OdrWarning', 'OdrError', 'OdrStop', - 'Data', 'RealData', 'Model', 'Output', 'ODR', - 'odr_error', 'odr_stop'] - -odr = __odrpack.odr -ODR_LOCK = Lock() - - -class OdrWarning(UserWarning): - """ - Warning indicating that the data passed into - ODR will cause problems when passed into 'odr' - that the user should be aware of. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - """ - pass - - -class OdrError(Exception): - """ - Exception indicating an error in fitting. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - - This is raised by `~scipy.odr.odr` if an error occurs during fitting. - """ - pass - - -class OdrStop(Exception): - """ - Exception stopping fitting. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - - You can raise this exception in your objective function to tell - `~scipy.odr.odr` to stop fitting. - """ - pass - - -# Backwards compatibility -odr_error = OdrError -odr_stop = OdrStop - -__odrpack._set_exceptions(OdrError, OdrStop) - - -def _conv(obj, dtype=None): - """ Convert an object to the preferred form for input to the odr routine. - """ - - if obj is None: - return obj - else: - if dtype is None: - obj = np.asarray(obj) - else: - obj = np.asarray(obj, dtype) - if obj.shape == (): - # Scalar. - return obj.dtype.type(obj) - else: - return obj - - -def _report_error(info): - """ Interprets the return code of the odr routine. - - Parameters - ---------- - info : int - The return code of the odr routine. - - Returns - ------- - problems : list(str) - A list of messages about why the odr() routine stopped. - """ - - stopreason = ('Blank', - 'Sum of squares convergence', - 'Parameter convergence', - 'Both sum of squares and parameter convergence', - 'Iteration limit reached')[info % 5] - - if info >= 5: - # questionable results or fatal error - - I = (info//10000 % 10, - info//1000 % 10, - info//100 % 10, - info//10 % 10, - info % 10) - problems = [] - - if I[0] == 0: - if I[1] != 0: - problems.append('Derivatives possibly not correct') - if I[2] != 0: - problems.append('Error occurred in callback') - if I[3] != 0: - problems.append('Problem is not full rank at solution') - problems.append(stopreason) - elif I[0] == 1: - if I[1] != 0: - problems.append('N < 1') - if I[2] != 0: - problems.append('M < 1') - if I[3] != 0: - problems.append('NP < 1 or NP > N') - if I[4] != 0: - problems.append('NQ < 1') - elif I[0] == 2: - if I[1] != 0: - problems.append('LDY and/or LDX incorrect') - if I[2] != 0: - problems.append('LDWE, LD2WE, LDWD, and/or LD2WD incorrect') - if I[3] != 0: - problems.append('LDIFX, LDSTPD, and/or LDSCLD incorrect') - if I[4] != 0: - problems.append('LWORK and/or LIWORK too small') - elif I[0] == 3: - if I[1] != 0: - problems.append('STPB and/or STPD incorrect') - if I[2] != 0: - problems.append('SCLB and/or SCLD incorrect') - if I[3] != 0: - problems.append('WE incorrect') - if I[4] != 0: - problems.append('WD incorrect') - elif I[0] == 4: - problems.append('Error in derivatives') - elif I[0] == 5: - problems.append('Error occurred in callback') - elif I[0] == 6: - problems.append('Numerical error detected') - - return problems - - else: - return [stopreason] - - -class Data: - """ - The data to fit. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - Parameters - ---------- - x : array_like - Observed data for the independent variable of the regression - y : array_like, optional - If array-like, observed data for the dependent variable of the - regression. A scalar input implies that the model to be used on - the data is implicit. - we : array_like, optional - If `we` is a scalar, then that value is used for all data points (and - all dimensions of the response variable). - If `we` is a rank-1 array of length q (the dimensionality of the - response variable), then this vector is the diagonal of the covariant - weighting matrix for all data points. - If `we` is a rank-1 array of length n (the number of data points), then - the i'th element is the weight for the i'th response variable - observation (single-dimensional only). - If `we` is a rank-2 array of shape (q, q), then this is the full - covariant weighting matrix broadcast to each observation. - If `we` is a rank-2 array of shape (q, n), then `we[:,i]` is the - diagonal of the covariant weighting matrix for the i'th observation. - If `we` is a rank-3 array of shape (q, q, n), then `we[:,:,i]` is the - full specification of the covariant weighting matrix for each - observation. - If the fit is implicit, then only a positive scalar value is used. - wd : array_like, optional - If `wd` is a scalar, then that value is used for all data points - (and all dimensions of the input variable). If `wd` = 0, then the - covariant weighting matrix for each observation is set to the identity - matrix (so each dimension of each observation has the same weight). - If `wd` is a rank-1 array of length m (the dimensionality of the input - variable), then this vector is the diagonal of the covariant weighting - matrix for all data points. - If `wd` is a rank-1 array of length n (the number of data points), then - the i'th element is the weight for the ith input variable observation - (single-dimensional only). - If `wd` is a rank-2 array of shape (m, m), then this is the full - covariant weighting matrix broadcast to each observation. - If `wd` is a rank-2 array of shape (m, n), then `wd[:,i]` is the - diagonal of the covariant weighting matrix for the ith observation. - If `wd` is a rank-3 array of shape (m, m, n), then `wd[:,:,i]` is the - full specification of the covariant weighting matrix for each - observation. - fix : array_like of ints, optional - The `fix` argument is the same as ifixx in the class ODR. It is an - array of integers with the same shape as data.x that determines which - input observations are treated as fixed. One can use a sequence of - length m (the dimensionality of the input observations) to fix some - dimensions for all observations. A value of 0 fixes the observation, - a value > 0 makes it free. - meta : dict, optional - Free-form dictionary for metadata. - - Notes - ----- - Each argument is attached to the member of the instance of the same name. - The structures of `x` and `y` are described in the Model class docstring. - If `y` is an integer, then the Data instance can only be used to fit with - implicit models where the dimensionality of the response is equal to the - specified value of `y`. - - The `we` argument weights the effect a deviation in the response variable - has on the fit. The `wd` argument weights the effect a deviation in the - input variable has on the fit. To handle multidimensional inputs and - responses easily, the structure of these arguments has the n'th - dimensional axis first. These arguments heavily use the structured - arguments feature of ODRPACK to conveniently and flexibly support all - options. See the ODRPACK User's Guide for a full explanation of how these - weights are used in the algorithm. Basically, a higher value of the weight - for a particular data point makes a deviation at that point more - detrimental to the fit. - - """ - - def __init__(self, x, y=None, we=None, wd=None, fix=None, meta=None): - self.x = _conv(x) - - if not isinstance(self.x, np.ndarray): - raise ValueError("Expected an 'ndarray' of data for 'x', " - f"but instead got data of type '{type(self.x).__name__}'") - - self.y = _conv(y) - self.we = _conv(we) - self.wd = _conv(wd) - self.fix = _conv(fix) - self.meta = {} if meta is None else meta - - def set_meta(self, **kwds): - """ Update the metadata dictionary with the keywords and data provided - by keywords. - - Examples - -------- - :: - - data.set_meta(lab="Ph 7; Lab 26", title="Ag110 + Ag108 Decay") - """ - - self.meta.update(kwds) - - def __getattr__(self, attr): - """ Dispatch attribute access to the metadata dictionary. - """ - if attr != "meta" and attr in self.meta: - return self.meta[attr] - else: - raise AttributeError(f"'{attr}' not in metadata") - - -class RealData(Data): - """ - The data, with weightings as actual standard deviations and/or - covariances. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - Parameters - ---------- - x : array_like - Observed data for the independent variable of the regression - y : array_like, optional - If array-like, observed data for the dependent variable of the - regression. A scalar input implies that the model to be used on - the data is implicit. - sx : array_like, optional - Standard deviations of `x`. - `sx` are standard deviations of `x` and are converted to weights by - dividing 1.0 by their squares. - sy : array_like, optional - Standard deviations of `y`. - `sy` are standard deviations of `y` and are converted to weights by - dividing 1.0 by their squares. - covx : array_like, optional - Covariance of `x` - `covx` is an array of covariance matrices of `x` and are converted to - weights by performing a matrix inversion on each observation's - covariance matrix. - covy : array_like, optional - Covariance of `y` - `covy` is an array of covariance matrices and are converted to - weights by performing a matrix inversion on each observation's - covariance matrix. - fix : array_like, optional - The argument and member fix is the same as Data.fix and ODR.ifixx: - It is an array of integers with the same shape as `x` that - determines which input observations are treated as fixed. One can - use a sequence of length m (the dimensionality of the input - observations) to fix some dimensions for all observations. A value - of 0 fixes the observation, a value > 0 makes it free. - meta : dict, optional - Free-form dictionary for metadata. - - Notes - ----- - The weights `wd` and `we` are computed from provided values as follows: - - `sx` and `sy` are converted to weights by dividing 1.0 by their squares. - For example, ``wd = 1./np.power(`sx`, 2)``. - - `covx` and `covy` are arrays of covariance matrices and are converted to - weights by performing a matrix inversion on each observation's covariance - matrix. For example, ``we[i] = np.linalg.inv(covy[i])``. - - These arguments follow the same structured argument conventions as wd and - we only restricted by their natures: `sx` and `sy` can't be rank-3, but - `covx` and `covy` can be. - - Only set *either* `sx` or `covx` (not both). Setting both will raise an - exception. Same with `sy` and `covy`. - - """ - - def __init__(self, x, y=None, sx=None, sy=None, covx=None, covy=None, - fix=None, meta=None): - if (sx is not None) and (covx is not None): - raise ValueError("cannot set both sx and covx") - if (sy is not None) and (covy is not None): - raise ValueError("cannot set both sy and covy") - - # Set flags for __getattr__ - self._ga_flags = {} - if sx is not None: - self._ga_flags['wd'] = 'sx' - else: - self._ga_flags['wd'] = 'covx' - if sy is not None: - self._ga_flags['we'] = 'sy' - else: - self._ga_flags['we'] = 'covy' - - self.x = _conv(x) - - if not isinstance(self.x, np.ndarray): - raise ValueError("Expected an 'ndarray' of data for 'x', " - f"but instead got data of type '{type(self.x).__name__}'") - - self.y = _conv(y) - self.sx = _conv(sx) - self.sy = _conv(sy) - self.covx = _conv(covx) - self.covy = _conv(covy) - self.fix = _conv(fix) - self.meta = {} if meta is None else meta - - def _sd2wt(self, sd): - """ Convert standard deviation to weights. - """ - - return 1./np.power(sd, 2) - - def _cov2wt(self, cov): - """ Convert covariance matrix(-ices) to weights. - """ - - from scipy.linalg import inv - - if len(cov.shape) == 2: - return inv(cov) - else: - weights = np.zeros(cov.shape, float) - - for i in range(cov.shape[-1]): # n - weights[:,:,i] = inv(cov[:,:,i]) - - return weights - - def __getattr__(self, attr): - - if attr not in ('wd', 'we'): - if attr != "meta" and attr in self.meta: - return self.meta[attr] - else: - raise AttributeError(f"'{attr}' not in metadata") - else: - lookup_tbl = {('wd', 'sx'): (self._sd2wt, self.sx), - ('wd', 'covx'): (self._cov2wt, self.covx), - ('we', 'sy'): (self._sd2wt, self.sy), - ('we', 'covy'): (self._cov2wt, self.covy)} - - func, arg = lookup_tbl[(attr, self._ga_flags[attr])] - - if arg is not None: - return func(*(arg,)) - else: - return None - - -class Model: - """ - The Model class stores information about the function you wish to fit. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - It stores the function itself, at the least, and optionally stores - functions which compute the Jacobians used during fitting. Also, one - can provide a function that will provide reasonable starting values - for the fit parameters possibly given the set of data. - - Parameters - ---------- - fcn : function - fcn(beta, x) --> y - fjacb : function - Jacobian of fcn wrt the fit parameters beta. - - fjacb(beta, x) --> @f_i(x,B)/@B_j - fjacd : function - Jacobian of fcn wrt the (possibly multidimensional) input - variable. - - fjacd(beta, x) --> @f_i(x,B)/@x_j - extra_args : tuple, optional - If specified, `extra_args` should be a tuple of extra - arguments to pass to `fcn`, `fjacb`, and `fjacd`. Each will be called - by `apply(fcn, (beta, x) + extra_args)` - estimate : array_like of rank-1 - Provides estimates of the fit parameters from the data - - estimate(data) --> estbeta - implicit : boolean - If TRUE, specifies that the model - is implicit; i.e `fcn(beta, x)` ~= 0 and there is no y data to fit - against - meta : dict, optional - freeform dictionary of metadata for the model - - Notes - ----- - Note that the `fcn`, `fjacb`, and `fjacd` operate on NumPy arrays and - return a NumPy array. The `estimate` object takes an instance of the - Data class. - - Here are the rules for the shapes of the argument and return - arrays of the callback functions: - - `x` - if the input data is single-dimensional, then `x` is rank-1 - array; i.e., ``x = array([1, 2, 3, ...]); x.shape = (n,)`` - If the input data is multi-dimensional, then `x` is a rank-2 array; - i.e., ``x = array([[1, 2, ...], [2, 4, ...]]); x.shape = (m, n)``. - In all cases, it has the same shape as the input data array passed to - `~scipy.odr.odr`. `m` is the dimensionality of the input data, - `n` is the number of observations. - `y` - if the response variable is single-dimensional, then `y` is a - rank-1 array, i.e., ``y = array([2, 4, ...]); y.shape = (n,)``. - If the response variable is multi-dimensional, then `y` is a rank-2 - array, i.e., ``y = array([[2, 4, ...], [3, 6, ...]]); y.shape = - (q, n)`` where `q` is the dimensionality of the response variable. - `beta` - rank-1 array of length `p` where `p` is the number of parameters; - i.e. ``beta = array([B_1, B_2, ..., B_p])`` - `fjacb` - if the response variable is multi-dimensional, then the - return array's shape is ``(q, p, n)`` such that ``fjacb(beta,x)[l,k,i] = - d f_l(beta,x)/d B_k`` evaluated at the ith data point. If ``q == 1``, then - the return array is only rank-2 and with shape ``(p, n)``. - `fjacd` - as with fjacb, only the return array's shape is ``(q, m, n)`` - such that ``fjacd(beta,x)[l,j,i] = d f_l(beta,x)/d X_j`` at the ith data - point. If ``q == 1``, then the return array's shape is ``(m, n)``. If - ``m == 1``, the shape is (q, n). If `m == q == 1`, the shape is ``(n,)``. - - """ - - def __init__(self, fcn, fjacb=None, fjacd=None, - extra_args=None, estimate=None, implicit=0, meta=None): - - self.fcn = fcn - self.fjacb = fjacb - self.fjacd = fjacd - - if extra_args is not None: - extra_args = tuple(extra_args) - - self.extra_args = extra_args - self.estimate = estimate - self.implicit = implicit - self.meta = meta if meta is not None else {} - - def set_meta(self, **kwds): - """ Update the metadata dictionary with the keywords and data provided - here. - - Examples - -------- - set_meta(name="Exponential", equation="y = a exp(b x) + c") - """ - - self.meta.update(kwds) - - def __getattr__(self, attr): - """ Dispatch attribute access to the metadata. - """ - - if attr != "meta" and attr in self.meta: - return self.meta[attr] - else: - raise AttributeError(f"'{attr}' not in metadata") - - -class Output: - """ - The Output class stores the output of an ODR run. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - Attributes - ---------- - beta : ndarray - Estimated parameter values, of shape (q,). - sd_beta : ndarray - Standard deviations of the estimated parameters, of shape (p,). - cov_beta : ndarray - Covariance matrix of the estimated parameters, of shape (p,p). - Note that this `cov_beta` is not scaled by the residual variance - `res_var`, whereas `sd_beta` is. This means - ``np.sqrt(np.diag(output.cov_beta * output.res_var))`` is the same - result as `output.sd_beta`. - delta : ndarray, optional - Array of estimated errors in input variables, of same shape as `x`. - eps : ndarray, optional - Array of estimated errors in response variables, of same shape as `y`. - xplus : ndarray, optional - Array of ``x + delta``. - y : ndarray, optional - Array ``y = fcn(x + delta)``. - res_var : float, optional - Residual variance. - sum_square : float, optional - Sum of squares error. - sum_square_delta : float, optional - Sum of squares of delta error. - sum_square_eps : float, optional - Sum of squares of eps error. - inv_condnum : float, optional - Inverse condition number (cf. ODRPACK UG p. 77). - rel_error : float, optional - Relative error in function values computed within fcn. - work : ndarray, optional - Final work array. - work_ind : dict, optional - Indices into work for drawing out values (cf. ODRPACK UG p. 83). - info : int, optional - Reason for returning, as output by ODRPACK (cf. ODRPACK UG p. 38). - stopreason : list of str, optional - `info` interpreted into English. - - Notes - ----- - Takes one argument for initialization, the return value from the - function `~scipy.odr.odr`. The attributes listed as "optional" above are - only present if `~scipy.odr.odr` was run with ``full_output=1``. - - """ - - def __init__(self, output): - self.beta = output[0] - self.sd_beta = output[1] - self.cov_beta = output[2] - - if len(output) == 4: - # full output - self.__dict__.update(output[3]) - self.stopreason = _report_error(self.info) - - def pprint(self): - """ Pretty-print important results. - """ - - print('Beta:', self.beta) - print('Beta Std Error:', self.sd_beta) - print('Beta Covariance:', self.cov_beta) - if hasattr(self, 'info'): - print('Residual Variance:',self.res_var) - print('Inverse Condition #:', self.inv_condnum) - print('Reason(s) for Halting:') - for r in self.stopreason: - print(f' {r}') - - -class ODR: - """ - The ODR class gathers all information and coordinates the running of the - main fitting routine. - - .. deprecated:: 1.17.0 - `scipy.odr` is deprecated and will be removed in SciPy 1.19.0. Please use - `pypi.org/project/odrpack/ `_ - instead. - - Members of instances of the ODR class have the same names as the arguments - to the initialization routine. - - Parameters - ---------- - data : Data class instance - instance of the Data class - model : Model class instance - instance of the Model class - - Other Parameters - ---------------- - beta0 : array_like of rank-1 - a rank-1 sequence of initial parameter values. Optional if - model provides an "estimate" function to estimate these values. - delta0 : array_like of floats of rank-1, optional - a (double-precision) float array to hold the initial values of - the errors in the input variables. Must be same shape as data.x - ifixb : array_like of ints of rank-1, optional - sequence of integers with the same length as beta0 that determines - which parameters are held fixed. A value of 0 fixes the parameter, - a value > 0 makes the parameter free. - ifixx : array_like of ints with same shape as data.x, optional - an array of integers with the same shape as data.x that determines - which input observations are treated as fixed. One can use a sequence - of length m (the dimensionality of the input observations) to fix some - dimensions for all observations. A value of 0 fixes the observation, - a value > 0 makes it free. - job : int, optional - an integer telling ODRPACK what tasks to perform. See p. 31 of the - ODRPACK User's Guide if you absolutely must set the value here. Use the - method set_job post-initialization for a more readable interface. - iprint : int, optional - an integer telling ODRPACK what to print. See pp. 33-34 of the - ODRPACK User's Guide if you absolutely must set the value here. Use the - method set_iprint post-initialization for a more readable interface. - errfile : str, optional - string with the filename to print ODRPACK errors to. If the file already - exists, an error will be thrown. The `overwrite` argument can be used to - prevent this. *Do Not Open This File Yourself!* - rptfile : str, optional - string with the filename to print ODRPACK summaries to. If the file - already exists, an error will be thrown. The `overwrite` argument can be - used to prevent this. *Do Not Open This File Yourself!* - ndigit : int, optional - integer specifying the number of reliable digits in the computation - of the function. - taufac : float, optional - float specifying the initial trust region. The default value is 1. - The initial trust region is equal to taufac times the length of the - first computed Gauss-Newton step. taufac must be less than 1. - sstol : float, optional - float specifying the tolerance for convergence based on the relative - change in the sum-of-squares. The default value is eps**(1/2) where eps - is the smallest value such that 1 + eps > 1 for double precision - computation on the machine. sstol must be less than 1. - partol : float, optional - float specifying the tolerance for convergence based on the relative - change in the estimated parameters. The default value is eps**(2/3) for - explicit models and ``eps**(1/3)`` for implicit models. partol must be less - than 1. - maxit : int, optional - integer specifying the maximum number of iterations to perform. For - first runs, maxit is the total number of iterations performed and - defaults to 50. For restarts, maxit is the number of additional - iterations to perform and defaults to 10. - stpb : array_like, optional - sequence (``len(stpb) == len(beta0)``) of relative step sizes to compute - finite difference derivatives wrt the parameters. - stpd : optional - array (``stpd.shape == data.x.shape`` or ``stpd.shape == (m,)``) of relative - step sizes to compute finite difference derivatives wrt the input - variable errors. If stpd is a rank-1 array with length m (the - dimensionality of the input variable), then the values are broadcast to - all observations. - sclb : array_like, optional - sequence (``len(stpb) == len(beta0)``) of scaling factors for the - parameters. The purpose of these scaling factors are to scale all of - the parameters to around unity. Normally appropriate scaling factors - are computed if this argument is not specified. Specify them yourself - if the automatic procedure goes awry. - scld : array_like, optional - array (scld.shape == data.x.shape or scld.shape == (m,)) of scaling - factors for the *errors* in the input variables. Again, these factors - are automatically computed if you do not provide them. If scld.shape == - (m,), then the scaling factors are broadcast to all observations. - work : ndarray, optional - array to hold the double-valued working data for ODRPACK. When - restarting, takes the value of self.output.work. - iwork : ndarray, optional - array to hold the integer-valued working data for ODRPACK. When - restarting, takes the value of self.output.iwork. - overwrite : bool, optional - If it is True, output files defined by `errfile` and `rptfile` are - overwritten. The default is False. - - Attributes - ---------- - data : Data - The data for this fit - model : Model - The model used in fit - output : Output - An instance if the Output class containing all of the returned - data from an invocation of ODR.run() or ODR.restart() - - """ - - def __init__(self, data, model, beta0=None, delta0=None, ifixb=None, - ifixx=None, job=None, iprint=None, errfile=None, rptfile=None, - ndigit=None, taufac=None, sstol=None, partol=None, maxit=None, - stpb=None, stpd=None, sclb=None, scld=None, work=None, iwork=None, - overwrite=False): - - self.data = data - self.model = model - - if beta0 is None: - if self.model.estimate is not None: - self.beta0 = _conv(self.model.estimate(self.data)) - else: - raise ValueError( - "must specify beta0 or provide an estimator with the model" - ) - else: - self.beta0 = _conv(beta0) - - if ifixx is None and data.fix is not None: - ifixx = data.fix - - if overwrite: - # remove output files for overwriting. - if rptfile is not None and os.path.exists(rptfile): - os.remove(rptfile) - if errfile is not None and os.path.exists(errfile): - os.remove(errfile) - - self.delta0 = _conv(delta0) - # These really are 32-bit integers in FORTRAN (gfortran), even on 64-bit - # platforms. - # XXX: some other FORTRAN compilers may not agree. - self.ifixx = _conv(ifixx, dtype=np.int32) - self.ifixb = _conv(ifixb, dtype=np.int32) - self.job = job - self.iprint = iprint - self.errfile = errfile - self.rptfile = rptfile - self.ndigit = ndigit - self.taufac = taufac - self.sstol = sstol - self.partol = partol - self.maxit = maxit - self.stpb = _conv(stpb) - self.stpd = _conv(stpd) - self.sclb = _conv(sclb) - self.scld = _conv(scld) - self.work = _conv(work) - self.iwork = _conv(iwork) - - self.output = None - - self._check() - - def _check(self): - """ Check the inputs for consistency, but don't bother checking things - that the builtin function odr will check. - """ - - x_s = list(self.data.x.shape) - - if isinstance(self.data.y, np.ndarray): - y_s = list(self.data.y.shape) - if self.model.implicit: - raise OdrError("an implicit model cannot use response data") - if self.job is not None and (self.job % 10) == 1: - raise OdrError("job parameter requests an implicit model," - " but an explicit model was passed") - else: - # implicit model with q == self.data.y - y_s = [self.data.y, x_s[-1]] - if not self.model.implicit: - raise OdrError("an explicit model needs response data") - self.set_job(fit_type=1) - - if x_s[-1] != y_s[-1]: - raise OdrError("number of observations do not match") - - n = x_s[-1] - - if len(x_s) == 2: - m = x_s[0] - else: - m = 1 - if len(y_s) == 2: - q = y_s[0] - else: - q = 1 - - p = len(self.beta0) - - # permissible output array shapes - - fcn_perms = [(q, n)] - fjacd_perms = [(q, m, n)] - fjacb_perms = [(q, p, n)] - - if q == 1: - fcn_perms.append((n,)) - fjacd_perms.append((m, n)) - fjacb_perms.append((p, n)) - if m == 1: - fjacd_perms.append((q, n)) - if p == 1: - fjacb_perms.append((q, n)) - if m == q == 1: - fjacd_perms.append((n,)) - if p == q == 1: - fjacb_perms.append((n,)) - - # try evaluating the supplied functions to make sure they provide - # sensible outputs - - arglist = (self.beta0, self.data.x) - if self.model.extra_args is not None: - arglist = arglist + self.model.extra_args - res = self.model.fcn(*arglist) - - if res.shape not in fcn_perms: - print(res.shape) - print(fcn_perms) - raise OdrError(f"fcn does not output {y_s}-shaped array") - - if self.model.fjacd is not None: - res = self.model.fjacd(*arglist) - if res.shape not in fjacd_perms: - raise OdrError( - f"fjacd does not output {repr((q, m, n))}-shaped array") - if self.model.fjacb is not None: - res = self.model.fjacb(*arglist) - if res.shape not in fjacb_perms: - raise OdrError( - f"fjacb does not output {repr((q, p, n))}-shaped array") - - # check shape of delta0 - - if self.delta0 is not None and self.delta0.shape != self.data.x.shape: - raise OdrError( - f"delta0 is not a {repr(self.data.x.shape)}-shaped array") - - if self.data.x.size == 0: - warn("Empty data detected for ODR instance. " - "Do not expect any fitting to occur", - OdrWarning, stacklevel=3) - - def _gen_work(self): - """ Generate a suitable work array if one does not already exist. - """ - - n = self.data.x.shape[-1] - p = self.beta0.shape[0] - - if len(self.data.x.shape) == 2: - m = self.data.x.shape[0] - else: - m = 1 - - if self.model.implicit: - q = self.data.y - elif len(self.data.y.shape) == 2: - q = self.data.y.shape[0] - else: - q = 1 - - if self.data.we is None: - ldwe = ld2we = 1 - elif len(self.data.we.shape) == 3: - ld2we, ldwe = self.data.we.shape[1:] - else: - we = self.data.we - ldwe = 1 - ld2we = 1 - if we.ndim == 1 and q == 1: - ldwe = n - elif we.ndim == 2: - if we.shape == (q, q): - ld2we = q - elif we.shape == (q, n): - ldwe = n - - if self.job % 10 < 2: - # ODR not OLS - lwork = (18 + 11*p + p*p + m + m*m + 4*n*q + 6*n*m + 2*n*q*p + - 2*n*q*m + q*q + 5*q + q*(p+m) + ldwe*ld2we*q) - else: - # OLS not ODR - lwork = (18 + 11*p + p*p + m + m*m + 4*n*q + 2*n*m + 2*n*q*p + - 5*q + q*(p+m) + ldwe*ld2we*q) - - if isinstance(self.work, np.ndarray) and self.work.shape == (lwork,)\ - and self.work.dtype.str.endswith('f8'): - # the existing array is fine - return - else: - self.work = np.zeros((lwork,), float) - - def set_job(self, fit_type=None, deriv=None, var_calc=None, - del_init=None, restart=None): - """ - Sets the "job" parameter is a hopefully comprehensible way. - - If an argument is not specified, then the value is left as is. The - default value from class initialization is for all of these options set - to 0. - - Parameters - ---------- - fit_type : {0, 1, 2} int - 0 -> explicit ODR - - 1 -> implicit ODR - - 2 -> ordinary least-squares - deriv : {0, 1, 2, 3} int - 0 -> forward finite differences - - 1 -> central finite differences - - 2 -> user-supplied derivatives (Jacobians) with results - checked by ODRPACK - - 3 -> user-supplied derivatives, no checking - var_calc : {0, 1, 2} int - 0 -> calculate asymptotic covariance matrix and fit - parameter uncertainties (V_B, s_B) using derivatives - recomputed at the final solution - - 1 -> calculate V_B and s_B using derivatives from last iteration - - 2 -> do not calculate V_B and s_B - del_init : {0, 1} int - 0 -> initial input variable offsets set to 0 - - 1 -> initial offsets provided by user in variable "work" - restart : {0, 1} int - 0 -> fit is not a restart - - 1 -> fit is a restart - - Notes - ----- - The permissible values are different from those given on pg. 31 of the - ODRPACK User's Guide only in that one cannot specify numbers greater than - the last value for each variable. - - If one does not supply functions to compute the Jacobians, the fitting - procedure will change deriv to 0, finite differences, as a default. To - initialize the input variable offsets by yourself, set del_init to 1 and - put the offsets into the "work" variable correctly. - - """ - - if self.job is None: - job_l = [0, 0, 0, 0, 0] - else: - job_l = [self.job // 10000 % 10, - self.job // 1000 % 10, - self.job // 100 % 10, - self.job // 10 % 10, - self.job % 10] - - if fit_type in (0, 1, 2): - job_l[4] = fit_type - if deriv in (0, 1, 2, 3): - job_l[3] = deriv - if var_calc in (0, 1, 2): - job_l[2] = var_calc - if del_init in (0, 1): - job_l[1] = del_init - if restart in (0, 1): - job_l[0] = restart - - self.job = (job_l[0]*10000 + job_l[1]*1000 + - job_l[2]*100 + job_l[3]*10 + job_l[4]) - - def set_iprint(self, init=None, so_init=None, - iter=None, so_iter=None, iter_step=None, final=None, so_final=None): - """ Set the iprint parameter for the printing of computation reports. - - If any of the arguments are specified here, then they are set in the - iprint member. If iprint is not set manually or with this method, then - ODRPACK defaults to no printing. If no filename is specified with the - member rptfile, then ODRPACK prints to stdout. One can tell ODRPACK to - print to stdout in addition to the specified filename by setting the - so_* arguments to this function, but one cannot specify to print to - stdout but not a file since one can do that by not specifying a rptfile - filename. - - There are three reports: initialization, iteration, and final reports. - They are represented by the arguments init, iter, and final - respectively. The permissible values are 0, 1, and 2 representing "no - report", "short report", and "long report" respectively. - - The argument iter_step (0 <= iter_step <= 9) specifies how often to make - the iteration report; the report will be made for every iter_step'th - iteration starting with iteration one. If iter_step == 0, then no - iteration report is made, regardless of the other arguments. - - If the rptfile is None, then any so_* arguments supplied will raise an - exception. - """ - if self.iprint is None: - self.iprint = 0 - - ip = [self.iprint // 1000 % 10, - self.iprint // 100 % 10, - self.iprint // 10 % 10, - self.iprint % 10] - - # make a list to convert iprint digits to/from argument inputs - # rptfile, stdout - ip2arg = [[0, 0], # none, none - [1, 0], # short, none - [2, 0], # long, none - [1, 1], # short, short - [2, 1], # long, short - [1, 2], # short, long - [2, 2]] # long, long - - if (self.rptfile is None and - (so_init is not None or - so_iter is not None or - so_final is not None)): - raise OdrError( - "no rptfile specified, cannot output to stdout twice") - - iprint_l = ip2arg[ip[0]] + ip2arg[ip[1]] + ip2arg[ip[3]] - - if init is not None: - iprint_l[0] = init - if so_init is not None: - iprint_l[1] = so_init - if iter is not None: - iprint_l[2] = iter - if so_iter is not None: - iprint_l[3] = so_iter - if final is not None: - iprint_l[4] = final - if so_final is not None: - iprint_l[5] = so_final - - if iter_step in range(10): - # 0..9 - ip[2] = iter_step - - ip[0] = ip2arg.index(iprint_l[0:2]) - ip[1] = ip2arg.index(iprint_l[2:4]) - ip[3] = ip2arg.index(iprint_l[4:6]) - - self.iprint = ip[0]*1000 + ip[1]*100 + ip[2]*10 + ip[3] - - def run(self): - """ Run the fitting routine with all of the information given and with ``full_output=1``. - - Returns - ------- - output : Output instance - This object is also assigned to the attribute .output . - """ # noqa: E501 - - args = (self.model.fcn, self.beta0, self.data.y, self.data.x) - kwds = {'full_output': 1} - kwd_l = ['ifixx', 'ifixb', 'job', 'iprint', 'errfile', 'rptfile', - 'ndigit', 'taufac', 'sstol', 'partol', 'maxit', 'stpb', - 'stpd', 'sclb', 'scld', 'work', 'iwork'] - - if self.delta0 is not None and (self.job // 10000) % 10 == 0: - # delta0 provided and fit is not a restart - self._gen_work() - - d0 = np.ravel(self.delta0) - - self.work[:len(d0)] = d0 - - # set the kwds from other objects explicitly - if self.model.fjacb is not None: - kwds['fjacb'] = self.model.fjacb - if self.model.fjacd is not None: - kwds['fjacd'] = self.model.fjacd - if self.data.we is not None: - kwds['we'] = self.data.we - if self.data.wd is not None: - kwds['wd'] = self.data.wd - if self.model.extra_args is not None: - kwds['extra_args'] = self.model.extra_args - - # implicitly set kwds from self's members - for attr in kwd_l: - obj = getattr(self, attr) - if obj is not None: - kwds[attr] = obj - - with ODR_LOCK: - self.output = Output(odr(*args, **kwds)) - - return self.output - - def restart(self, iter=None): - """ Restarts the run with iter more iterations. - - Parameters - ---------- - iter : int, optional - ODRPACK's default for the number of new iterations is 10. - - Returns - ------- - output : Output instance - This object is also assigned to the attribute .output . - """ - - if self.output is None: - raise OdrError("cannot restart: run() has not been called before") - - self.set_job(restart=1) - self.work = self.output.work - self.iwork = self.output.iwork - - self.maxit = iter - - return self.run() diff --git a/scipy/odr/meson.build b/scipy/odr/meson.build deleted file mode 100644 index 921710074f0e..000000000000 --- a/scipy/odr/meson.build +++ /dev/null @@ -1,38 +0,0 @@ -odrpack = static_library('odrpack', - [ - 'odrpack/d_lpk.f', - 'odrpack/d_mprec.f', - 'odrpack/d_odr.f', - 'odrpack/dlunoc.f' - ], - fortran_args: _fflag_Wno_conversion, # silence "conversion from REAL(8) to INTEGER(4)" - override_options: ['b_lto=false'], - gnu_symbol_visibility: 'hidden', -) - -py3.extension_module('__odrpack', - '__odrpack.c', - link_with: odrpack, - link_args: version_link_args, - dependencies: [blas_lp64_dep, np_dep], - install: true, - link_language: 'fortran', - subdir: 'scipy/odr' -) - - -python_sources = [ - '__init__.py', - '_add_newdocs.py', - '_models.py', - '_odrpack.py', - 'models.py', - 'odrpack.py' -] - -py3.install_sources( - python_sources, - subdir: 'scipy/odr' -) - -subdir('tests') diff --git a/scipy/odr/models.py b/scipy/odr/models.py deleted file mode 100644 index e144e443a284..000000000000 --- a/scipy/odr/models.py +++ /dev/null @@ -1,27 +0,0 @@ -# This file is not meant for public use and will be removed in SciPy v2.0.0. -# Use the `scipy.odr` namespace for importing the functions -# included below. - - -__all__ = [ # noqa: F822 - 'Model', 'exponential', 'multilinear', 'unilinear', - 'quadratic', 'polynomial' -] - - -def __dir__(): - return __all__ - - -def __getattr__(name): - msg = ("`scipy.odr` is deprecated as of version 1.17.0 and will be removed in " - "SciPy 1.19.0. Please use `https://pypi.org/project/odrpack/` instead.") - if name not in __all__: - raise AttributeError( - f"`scipy.odr.models` has no attribute {name}. In addition, {msg}") - - import warnings - from . import _models - warnings.warn(msg, category=DeprecationWarning, stacklevel=2) - - return getattr(_models, name) diff --git a/scipy/odr/odrpack.h b/scipy/odr/odrpack.h deleted file mode 100644 index 19ac5b9f0bb5..000000000000 --- a/scipy/odr/odrpack.h +++ /dev/null @@ -1,83 +0,0 @@ -#define PY_SSIZE_T_CLEAN -#include "Python.h" -#include "numpy/arrayobject.h" - -#ifdef HAVE_BLAS_ILP64 - -#define F_INT npy_int64 -#define F_INT_NPY NPY_INT64 - -#if NPY_BITSOF_SHORT == 64 -#define F_INT_PYFMT "h" -#elif NPY_BITSOF_INT == 64 -#define F_INT_PYFMT "i" -#elif NPY_BITSOF_LONG == 64 -#define F_INT_PYFMT "l" -#elif NPY_BITSOF_LONGLONG == 64 -#define F_INT_PYFMT "L" -#else -#error No compatible 64-bit integer size. \ - Please contact NumPy maintainers and give detailed information about your \ - compiler and platform, or set NPY_USE_BLAS64_=0 -#endif - -#else - -#define F_INT int -#define F_INT_NPY NPY_INT -#define F_INT_PYFMT "i" - -#endif - -#if defined(NO_APPEND_FORTRAN) -#if defined(UPPERCASE_FORTRAN) -#define F_FUNC(f,F) F -#else -#define F_FUNC(f,F) f -#endif -#else -#if defined(UPPERCASE_FORTRAN) -#define F_FUNC(f,F) F##_ -#else -#define F_FUNC(f,F) f##_ -#endif -#endif - -#define PYERR(errobj,message) {PyErr_SetString(errobj,message); goto fail;} -#define PYERR2(errobj,message) {PyErr_Print(); PyErr_SetString(errobj, message); goto fail;} -#define ISCONTIGUOUS(m) ((m)->flags & CONTIGUOUS) - -#define MAX(n1,n2) ((n1) > (n2))?(n1):(n2); -#define MIN(n1,n2) ((n1) > (n2))?(n2):(n1); - -struct ODR_info_ { - PyObject* fcn; - PyObject* fjacb; - PyObject* fjacd; - PyObject* pyBeta; - PyObject* extra_args; -}; - -typedef struct ODR_info_ ODR_info; - -static ODR_info odr_global; - -static PyObject *odr_error=NULL; -static PyObject *odr_stop=NULL; - -void fcn_callback(F_INT *n, F_INT *m, F_INT *np, F_INT *nq, F_INT *ldn, F_INT *ldm, - F_INT *ldnp, double *beta, double *xplusd, F_INT *ifixb, - F_INT *ifixx, F_INT *ldfix, F_INT *ideval, double *f, - double *fjacb, double *fjacd, F_INT *istop); - -PyObject *gen_output(F_INT n, F_INT m, F_INT np, F_INT nq, F_INT ldwe, F_INT ld2we, - PyArrayObject *beta, PyArrayObject *work, PyArrayObject *iwork, - F_INT isodr, F_INT info, int full_output); - -PyObject *odr(PyObject *self, PyObject *args, PyObject *kwds); - -#define PyArray_CONTIGUOUS(m) (ISCONTIGUOUS(m) ? Py_INCREF(m), m : \ -(PyArrayObject *)(PyArray_ContiguousFromObject((PyObject *)(m), \ -(m)->descr->type_num, 0,0))) -#define D(dbg) printf("we're here: %i\n", dbg) -#define EXIST(name,obj) if (obj==NULL){printf("%s\n",name);} diff --git a/scipy/odr/odrpack.py b/scipy/odr/odrpack.py deleted file mode 100644 index d3c3f029f107..000000000000 --- a/scipy/odr/odrpack.py +++ /dev/null @@ -1,28 +0,0 @@ -# This file is not meant for public use and will be removed in SciPy v2.0.0. -# Use the `scipy.odr` namespace for importing the functions -# included below. - - -__all__ = [ # noqa: F822 - 'odr', 'OdrWarning', 'OdrError', 'OdrStop', - 'Data', 'RealData', 'Model', 'Output', 'ODR', - 'odr_error', 'odr_stop' -] - - -def __dir__(): - return __all__ - - -def __getattr__(name): - msg = ("`scipy.odr` is deprecated as of version 1.17.0 and will be removed in " - "SciPy 1.19.0. Please use `https://pypi.org/project/odrpack/` instead.") - if name not in __all__: - raise AttributeError( - f"`scipy.odr.odrpack` has no attribute {name}. In addition, {msg}") - - import warnings - from . import _odrpack - warnings.warn(msg, category=DeprecationWarning, stacklevel=2) - - return getattr(_odrpack, name) diff --git a/scipy/odr/odrpack/Makefile b/scipy/odr/odrpack/Makefile deleted file mode 100644 index 7e845015cb73..000000000000 --- a/scipy/odr/odrpack/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -# Make the ODRPACK library - -FC = g77 -FOPT = -O -LIB = libodrpack.a -OBJS = d_odr.o d_mprec.o d_lpkbls.o dlunoc.o - -.f.o: - $(FC) $(FOPT) -c $< - -$(LIB): $(OBJS) - ar cru $(LIB) $(OBJS) - -all: $(LIB) - -clean: - rm -f $(LIB) $(OBJS) - diff --git a/scipy/odr/odrpack/d_lpk.f b/scipy/odr/odrpack/d_lpk.f deleted file mode 100644 index ba3b24f32f70..000000000000 --- a/scipy/odr/odrpack/d_lpk.f +++ /dev/null @@ -1,1211 +0,0 @@ -*DCHEX - SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB) -C***BEGIN PROLOGUE DCHEX -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D7B -C***KEYWORDS CHOLESKY DECOMPOSITION,DOUBLE PRECISION,EXCHANGE, -C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE -C***AUTHOR STEWART, G. W., (U. OF MARYLAND) -C***PURPOSE UPDATES THE CHOLESKY FACTORIZATION A=TRANS(R)*R OF A -C POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL -C PERMUTATIONS OF THE FORM TRANS(E)*A*E WHERE E IS A -C PERMUTATION MATRIX. -C***DESCRIPTION -C DCHEX UPDATES THE CHOLESKY FACTORIZATION -C A = TRANS(R)*R -C OF A POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL -C PERMUTATIONS OF THE FORM -C TRANS(E)*A*E -C WHERE E IS A PERMUTATION MATRIX. SPECIFICALLY, GIVEN -C AN UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX -C E (WHICH IS SPECIFIED BY K, L, AND JOB), DCHEX DETERMINES -C AN ORTHOGONAL MATRIX U SUCH THAT -C U*R*E = RR, -C WHERE RR IS UPPER TRIANGULAR. AT THE USERS OPTION, THE -C TRANSFORMATION U WILL BE MULTIPLIED INTO THE ARRAY Z. -C IF A = TRANS(X)*X, SO THAT R IS THE TRIANGULAR PART OF THE -C QR FACTORIZATION OF X, THEN RR IS THE TRIANGULAR PART OF THE -C QR FACTORIZATION OF X*E, I.E. X WITH ITS COLUMNS PERMUTED. -C FOR A LESS TERSE DESCRIPTION OF WHAT DCHEX DOES AND HOW -C IT MAY BE APPLIED, SEE THE LINPACK GUIDE. -C THE MATRIX Q IS DETERMINED AS THE PRODUCT U(L-K)*...*U(1) -C OF PLANE ROTATIONS OF THE FORM -C ( C(I) S(I) ) -C ( ) , -C ( -S(I) C(I) ) -C WHERE C(I) IS DOUBLE PRECISION. THE ROWS THESE ROTATIONS OPERATE -C ON ARE DESCRIBED BELOW. -C THERE ARE TWO TYPES OF PERMUTATIONS, WHICH ARE DETERMINED -C BY THE VALUE OF JOB. -C 1. RIGHT CIRCULAR SHIFT (JOB = 1). -C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER. -C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. -C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) -C ACTS IN THE (L-I,L-I+1)-PLANE. -C 2. LEFT CIRCULAR SHIFT (JOB = 2). -C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER -C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. -C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) -C ACTS IN THE (K+I-1,K+I)-PLANE. -C ON ENTRY -C R DOUBLE PRECISION(LDR,P), WHERE LDR .GE. P. -C R CONTAINS THE UPPER TRIANGULAR FACTOR -C THAT IS TO BE UPDATED. ELEMENTS OF R -C BELOW THE DIAGONAL ARE NOT REFERENCED. -C LDR INTEGER. -C LDR IS THE LEADING DIMENSION OF THE ARRAY R. -C P INTEGER. -C P IS THE ORDER OF THE MATRIX R. -C K INTEGER. -C K IS THE FIRST COLUMN TO BE PERMUTED. -C L INTEGER. -C L IS THE LAST COLUMN TO BE PERMUTED. -C L MUST BE STRICTLY GREATER THAN K. -C Z DOUBLE PRECISION(LDZ,N)Z), WHERE LDZ .GE. P. -C Z IS AN ARRAY OF NZ P-VECTORS INTO WHICH THE -C TRANSFORMATION U IS MULTIPLIED. Z IS -C NOT REFERENCED IF NZ = 0. -C LDZ INTEGER. -C LDZ IS THE LEADING DIMENSION OF THE ARRAY Z. -C NZ INTEGER. -C NZ IS THE NUMBER OF COLUMNS OF THE MATRIX Z. -C JOB INTEGER. -C JOB DETERMINES THE TYPE OF PERMUTATION. -C JOB = 1 RIGHT CIRCULAR SHIFT. -C JOB = 2 LEFT CIRCULAR SHIFT. -C ON RETURN -C R CONTAINS THE UPDATED FACTOR. -C Z CONTAINS THE UPDATED MATRIX Z. -C C DOUBLE PRECISION(P). -C C CONTAINS THE COSINES OF THE TRANSFORMING ROTATIONS. -C S DOUBLE PRECISION(P). -C S CONTAINS THE SINES OF THE TRANSFORMING ROTATIONS. -C LINPACK. THIS VERSION DATED 08/14/78 . -C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DROTG -C***END PROLOGUE DCHEX - -C...SCALAR ARGUMENTS - INTEGER - + JOB,K,L,LDR,LDZ,NZ,P - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + C(*),R(LDR,*),S(*),Z(LDZ,*) - -C...LOCAL SCALARS - DOUBLE PRECISION - + T,T1 - INTEGER - + I,II,IL,IU,J,JJ,KM1,KP1,LM1,LMK - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DROTG - -C...INTRINSIC FUNCTIONS - INTRINSIC - + MAX0,MIN0 - - -C***FIRST EXECUTABLE STATEMENT DCHEX - - - KM1 = K - 1 - KP1 = K + 1 - LMK = L - K - LM1 = L - 1 - -C PERFORM THE APPROPRIATE TASK. - - GO TO (10,130), JOB - -C RIGHT CIRCULAR SHIFT. - - 10 CONTINUE - -C REORDER THE COLUMNS. - - DO 20 I = 1, L - II = L - I + 1 - S(I) = R(II,L) - 20 CONTINUE - DO 40 JJ = K, LM1 - J = LM1 - JJ + K - DO 30 I = 1, J - R(I,J+1) = R(I,J) - 30 CONTINUE - R(J+1,J+1) = 0.0D0 - 40 CONTINUE - IF (K .EQ. 1) GO TO 60 - DO 50 I = 1, KM1 - II = L - I + 1 - R(I,K) = S(II) - 50 CONTINUE - 60 CONTINUE - -C CALCULATE THE ROTATIONS. - - T = S(1) - DO 70 I = 1, LMK - T1 = S(I) - CALL DROTG(S(I+1),T,C(I),T1) - S(I) = T1 - T = S(I+1) - 70 CONTINUE - R(K,K) = T - DO 90 J = KP1, P - IL = MAX0(1,L-J+1) - DO 80 II = IL, LMK - I = L - II - T = C(II)*R(I,J) + S(II)*R(I+1,J) - R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) - R(I,J) = T - 80 CONTINUE - 90 CONTINUE - -C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. - - IF (NZ .LT. 1) GO TO 120 - DO 110 J = 1, NZ - DO 100 II = 1, LMK - I = L - II - T = C(II)*Z(I,J) + S(II)*Z(I+1,J) - Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) - Z(I,J) = T - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - GO TO 260 - -C LEFT CIRCULAR SHIFT - - 130 CONTINUE - -C REORDER THE COLUMNS - - DO 140 I = 1, K - II = LMK + I - S(II) = R(I,K) - 140 CONTINUE - DO 160 J = K, LM1 - DO 150 I = 1, J - R(I,J) = R(I,J+1) - 150 CONTINUE - JJ = J - KM1 - S(JJ) = R(J+1,J+1) - 160 CONTINUE - DO 170 I = 1, K - II = LMK + I - R(I,L) = S(II) - 170 CONTINUE - DO 180 I = KP1, L - R(I,L) = 0.0D0 - 180 CONTINUE - -C REDUCTION LOOP. - - DO 220 J = K, P - IF (J .EQ. K) GO TO 200 - -C APPLY THE ROTATIONS. - - IU = MIN0(J-1,L-1) - DO 190 I = K, IU - II = I - K + 1 - T = C(II)*R(I,J) + S(II)*R(I+1,J) - R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) - R(I,J) = T - 190 CONTINUE - 200 CONTINUE - IF (J .GE. L) GO TO 210 - JJ = J - K + 1 - T = S(JJ) - CALL DROTG(R(J,J),T,C(JJ),S(JJ)) - 210 CONTINUE - 220 CONTINUE - -C APPLY THE ROTATIONS TO Z. - - IF (NZ .LT. 1) GO TO 250 - DO 240 J = 1, NZ - DO 230 I = K, LM1 - II = I - KM1 - T = C(II)*Z(I,J) + S(II)*Z(I+1,J) - Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) - Z(I,J) = T - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN - END -*DPODI - SUBROUTINE DPODI(A,LDA,N,DET,JOB) -C***BEGIN PROLOGUE DPODI -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2B1B,D3B1B -C***KEYWORDS DETERMINANT,DOUBLE PRECISION,FACTOR,INVERSE, -C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN DOUBLE -C PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE ABSTRACT) -C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. -C***DESCRIPTION -C DPODI COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN -C DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE BELOW) -C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. -C ON ENTRY -C A DOUBLE PRECISION(LDA, N) -C THE OUTPUT A FROM DPOCO OR DPOFA -C OR THE OUTPUT X FROM DQRDC. -C LDA INTEGER -C THE LEADING DIMENSION OF THE ARRAY A . -C N INTEGER -C THE ORDER OF THE MATRIX A . -C JOB INTEGER -C = 11 BOTH DETERMINANT AND INVERSE. -C = 01 INVERSE ONLY. -C = 10 DETERMINANT ONLY. -C ON RETURN -C A IF DPOCO OR DPOFA WAS USED TO FACTOR A , THEN -C DPODI PRODUCES THE UPPER HALF OF INVERSE(A) . -C IF DQRDC WAS USED TO DECOMPOSE X , THEN -C DPODI PRODUCES THE UPPER HALF OF INVERSE(TRANS(X)*X) -C WHERE TRANS(X) IS THE TRANSPOSE. -C ELEMENTS OF A BELOW THE DIAGONAL ARE UNCHANGED. -C IF THE UNITS DIGIT OF JOB IS ZERO, A IS UNCHANGED. -C DET DOUBLE PRECISION(2) -C DETERMINANT OF A OR OF TRANS(X)*X IF REQUESTED. -C OTHERWISE NOT REFERENCED. -C DETERMINANT = DET(1) * 10.0**DET(2) -C WITH 1.0 .LE. DET(1) .LT. 10.0 -C OR DET(1) .EQ. 0.0 . -C ERROR CONDITION -C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS -C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. -C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY -C AND IF DPOCO OR DPOFA HAS SET INFO .EQ. 0 . -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DSCAL -C***END PROLOGUE DPODI - -C...SCALAR ARGUMENTS - INTEGER JOB,LDA,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION A(LDA,*),DET(*) - -C...LOCAL SCALARS - DOUBLE PRECISION S,T - INTEGER I,J,JM1,K,KP1 - -C...EXTERNAL SUBROUTINES - EXTERNAL DAXPY,DSCAL - -C...INTRINSIC FUNCTIONS - INTRINSIC MOD - - -C***FIRST EXECUTABLE STATEMENT DPODI - - - IF (JOB/10 .EQ. 0) GO TO 70 - DET(1) = 1.0D0 - DET(2) = 0.0D0 - S = 10.0D0 - DO 50 I = 1, N - DET(1) = A(I,I)**2*DET(1) -C ...EXIT - IF (DET(1) .EQ. 0.0D0) GO TO 60 - 10 IF (DET(1) .GE. 1.0D0) GO TO 20 - DET(1) = S*DET(1) - DET(2) = DET(2) - 1.0D0 - GO TO 10 - 20 CONTINUE - 30 IF (DET(1) .LT. S) GO TO 40 - DET(1) = DET(1)/S - DET(2) = DET(2) + 1.0D0 - GO TO 30 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - -C COMPUTE INVERSE(R) - - IF (MOD(JOB,10) .EQ. 0) GO TO 140 - DO 100 K = 1, N - A(K,K) = 1.0D0/A(K,K) - T = -A(K,K) - CALL DSCAL(K-1,T,A(1,K),1) - KP1 = K + 1 - IF (N .LT. KP1) GO TO 90 - DO 80 J = KP1, N - T = A(K,J) - A(K,J) = 0.0D0 - CALL DAXPY(K,T,A(1,K),1,A(1,J),1) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - -C FORM INVERSE(R) * TRANS(INVERSE(R)) - - DO 130 J = 1, N - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 120 - DO 110 K = 1, JM1 - T = A(K,J) - CALL DAXPY(K,T,A(1,J),1,A(1,K),1) - 110 CONTINUE - 120 CONTINUE - T = A(J,J) - CALL DSCAL(J,T,A(1,J),1) - 130 CONTINUE - 140 CONTINUE - RETURN - END -*DQRDC - SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB) -C***BEGIN PROLOGUE DQRDC -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D5 -C***KEYWORDS DECOMPOSITION,DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK, -C MATRIX,ORTHOGONAL TRIANGULAR -C***AUTHOR STEWART, G. W., (U. OF MARYLAND) -C***PURPOSE USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR FACTORI- -C ZATION OF N BY P MATRIX X. COLUMN PIVOTING IS OPTIONAL. -C***DESCRIPTION -C DQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR -C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING -C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE -C PERFORMED AT THE USER'S OPTION. -C ON ENTRY -C X DOUBLE PRECISION(LDX,P), WHERE LDX .GE. N. -C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE -C COMPUTED. -C LDX INTEGER. -C LDX IS THE LEADING DIMENSION OF THE ARRAY X. -C N INTEGER. -C N IS THE NUMBER OF ROWS OF THE MATRIX X. -C P INTEGER. -C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. -C JPVT INTEGER(P). -C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION -C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X -C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE -C VALUE OF JPVT(K). -C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL -C COLUMN. -C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN. -C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN. -C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS -C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL -C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS -C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY -C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE -C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN -C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST -C REDUCED NORM. JPVT IS NOT REFERENCED IF -C JOB .EQ. 0. -C WORK DOUBLE PRECISION(P). -C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF -C JOB .EQ. 0. -C JOB INTEGER. -C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING. -C IF JOB .EQ. 0, NO PIVOTING IS DONE. -C IF JOB .NE. 0, PIVOTING IS DONE. -C ON RETURN -C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER -C TRIANGULAR MATRIX R OF THE QR FACTORIZATION. -C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM -C WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION -C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS -C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT -C OF THE ORIGINAL MATRIX X BUT THAT OF X -C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT. -C QRAUX DOUBLE PRECISION(P). -C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER -C THE ORTHOGONAL PART OF THE DECOMPOSITION. -C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE -C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO -C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED. -C LINPACK. THIS VERSION DATED 08/14/78 . -C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DDOT,DNRM2,DSCAL,DSWAP -C***END PROLOGUE DQRDC - -C...SCALAR ARGUMENTS - INTEGER - + JOB,LDX,N,P - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + QRAUX(*),WORK(*),X(LDX,*) - INTEGER - + JPVT(*) - -C...LOCAL SCALARS - DOUBLE PRECISION - + MAXNRM,NRMXL,T,TT - INTEGER - + J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU - LOGICAL - + NEGJ,SWAPJ - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DDOT,DNRM2 - EXTERNAL - + DDOT,DNRM2 - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DAXPY,DSCAL,DSWAP - -C...INTRINSIC FUNCTIONS - INTRINSIC - + DABS,DMAX1,DSIGN,DSQRT,MIN0 - - -C***FIRST EXECUTABLE STATEMENT DQRDC - - - PL = 1 - PU = 0 - IF (JOB .EQ. 0) GO TO 60 - -C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS -C ACCORDING TO JPVT. - - DO 20 J = 1, P - SWAPJ = JPVT(J) .GT. 0 - NEGJ = JPVT(J) .LT. 0 - JPVT(J) = J - IF (NEGJ) JPVT(J) = -J - IF (.NOT.SWAPJ) GO TO 10 - IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1) - JPVT(J) = JPVT(PL) - JPVT(PL) = J - PL = PL + 1 - 10 CONTINUE - 20 CONTINUE - PU = P - DO 50 JJ = 1, P - J = P - JJ + 1 - IF (JPVT(J) .GE. 0) GO TO 40 - JPVT(J) = -JPVT(J) - IF (J .EQ. PU) GO TO 30 - CALL DSWAP(N,X(1,PU),1,X(1,J),1) - JP = JPVT(PU) - JPVT(PU) = JPVT(J) - JPVT(J) = JP - 30 CONTINUE - PU = PU - 1 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - -C COMPUTE THE NORMS OF THE FREE COLUMNS. - - IF (PU .LT. PL) GO TO 80 - DO 70 J = PL, PU - QRAUX(J) = DNRM2(N,X(1,J),1) - WORK(J) = QRAUX(J) - 70 CONTINUE - 80 CONTINUE - -C PERFORM THE HOUSEHOLDER REDUCTION OF X. - - LUP = MIN0(N,P) - DO 200 L = 1, LUP - IF (L .LT. PL .OR. L .GE. PU) GO TO 120 - -C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT -C INTO THE PIVOT POSITION. - - MAXNRM = 0.0D0 - MAXJ = L - DO 100 J = L, PU - IF (QRAUX(J) .LE. MAXNRM) GO TO 90 - MAXNRM = QRAUX(J) - MAXJ = J - 90 CONTINUE - 100 CONTINUE - IF (MAXJ .EQ. L) GO TO 110 - CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1) - QRAUX(MAXJ) = QRAUX(L) - WORK(MAXJ) = WORK(L) - JP = JPVT(MAXJ) - JPVT(MAXJ) = JPVT(L) - JPVT(L) = JP - 110 CONTINUE - 120 CONTINUE - QRAUX(L) = 0.0D0 - IF (L .EQ. N) GO TO 190 - -C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. - - NRMXL = DNRM2(N-L+1,X(L,L),1) - IF (NRMXL .EQ. 0.0D0) GO TO 180 - IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L)) - CALL DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1) - X(L,L) = 1.0D0 + X(L,L) - -C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, -C UPDATING THE NORMS. - - LP1 = L + 1 - IF (P .LT. LP1) GO TO 170 - DO 160 J = LP1, P - T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) - CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1) - IF (J .LT. PL .OR. J .GT. PU) GO TO 150 - IF (QRAUX(J) .EQ. 0.0D0) GO TO 150 - TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2 - TT = DMAX1(TT,0.0D0) - T = TT - TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2 - IF (TT .EQ. 1.0D0) GO TO 130 - QRAUX(J) = QRAUX(J)*DSQRT(T) - GO TO 140 - 130 CONTINUE - QRAUX(J) = DNRM2(N-L,X(L+1,J),1) - WORK(J) = QRAUX(J) - 140 CONTINUE - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - -C SAVE THE TRANSFORMATION. - - QRAUX(L) = X(L,L) - X(L,L) = -NRMXL - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - RETURN - END -*DQRSL - SUBROUTINE DQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) -C***BEGIN PROLOGUE DQRSL -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D9,D2A1 -C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX, -C ORTHOGONAL TRIANGULAR,SOLVE -C***AUTHOR STEWART, G. W., (U. OF MARYLAND) -C***PURPOSE APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE -C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. -C***DESCRIPTION -C DQRSL APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE -C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. -C FOR K .LE. MIN(N,P), LET XK BE THE MATRIX -C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) -C FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL -C N X P MATRIX X THAT WAS INPUT TO DQRDC (IF NO PIVOTING WAS -C DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR -C ORIGINAL ORDER). DQRDC PRODUCES A FACTORED ORTHOGONAL MATRIX Q -C AND AN UPPER TRIANGULAR MATRIX R SUCH THAT -C XK = Q * (R) -C (0) -C THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS -C X AND QRAUX. -C ON ENTRY -C X DOUBLE PRECISION(LDX,P). -C X CONTAINS THE OUTPUT OF DQRDC. -C LDX INTEGER. -C LDX IS THE LEADING DIMENSION OF THE ARRAY X. -C N INTEGER. -C N IS THE NUMBER OF ROWS OF THE MATRIX XK. IT MUST -C HAVE THE SAME VALUE AS N IN DQRDC. -C K INTEGER. -C K IS THE NUMBER OF COLUMNS OF THE MATRIX XK. K -C MUST NOT BE GREATER THAN MIN(N,P), WHERE P IS THE -C SAME AS IN THE CALLING SEQUENCE TO DQRDC. -C QRAUX DOUBLE PRECISION(P). -C QRAUX CONTAINS THE AUXILIARY OUTPUT FROM DQRDC. -C Y DOUBLE PRECISION(N) -C Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED -C BY DQRSL. -C JOB INTEGER. -C JOB SPECIFIES WHAT IS TO BE COMPUTED. JOB HAS -C THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING -C MEANING. -C IF A .NE. 0, COMPUTE QY. -C IF B,C,D, OR E .NE. 0, COMPUTE QTY. -C IF C .NE. 0, COMPUTE B. -C IF D .NE. 0, COMPUTE RSD. -C IF E .NE. 0, COMPUTE XB. -C NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB -C AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR -C WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING -C SEQUENCE. -C ON RETURN -C QY DOUBLE PRECISION(N). -C QY CONTAINS Q*Y, IF ITS COMPUTATION HAS BEEN -C REQUESTED. -C QTY DOUBLE PRECISION(N). -C QTY CONTAINS TRANS(Q)*Y, IF ITS COMPUTATION HAS -C BEEN REQUESTED. HERE TRANS(Q) IS THE -C TRANSPOSE OF THE MATRIX Q. -C B DOUBLE PRECISION(K) -C B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM -C MINIMIZE NORM2(Y - XK*B), -C IF ITS COMPUTATION HAS BEEN REQUESTED. (NOTE THAT -C IF PIVOTING WAS REQUESTED IN DQRDC, THE J-TH -C COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J) -C OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO DQRDC.) -C RSD DOUBLE PRECISION(N). -C RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B, -C IF ITS COMPUTATION HAS BEEN REQUESTED. RSD IS -C ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE -C ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK. -C XB DOUBLE PRECISION(N). -C XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B, -C IF ITS COMPUTATION HAS BEEN REQUESTED. XB IS ALSO -C THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE -C OF X. -C INFO INTEGER. -C INFO IS ZERO UNLESS THE COMPUTATION OF B HAS -C BEEN REQUESTED AND R IS EXACTLY SINGULAR. IN -C THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO -C DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED. -C THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED -C IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE -C CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM. -C TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME -C ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE. A -C FREQUENTLY OCCURRING EXAMPLE IS WHEN ONE WISHES TO COMPUTE -C ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY. IN THIS -C CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE -C PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE -C COMPUTED. THUS THE CALLING SEQUENCE -C CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) -C WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD -C OVERWRITING Y. MORE GENERALLY, EACH ITEM IN THE FOLLOWING -C LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR -C A SINGLE CALLING SEQUENCE. -C 1. (Y,QTY,B) (RSD) (XB) (QY) -C 2. (Y,QTY,RSD) (B) (XB) (QY) -C 3. (Y,QTY,XB) (B) (RSD) (QY) -C 4. (Y,QY) (QTY,B) (RSD) (XB) -C 5. (Y,QY) (QTY,RSD) (B) (XB) -C 6. (Y,QY) (QTY,XB) (B) (RSD) -C IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO -C THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP. -C LINPACK. THIS VERSION DATED 08/14/78 . -C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DCOPY,DDOT -C***END PROLOGUE DQRSL - -C...SCALAR ARGUMENTS - INTEGER - + INFO,JOB,K,LDX,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + B(*),QRAUX(*),QTY(*),QY(*),RSD(*),X(LDX,*),XB(*), - + Y(*) - -C...LOCAL SCALARS - DOUBLE PRECISION - + T,TEMP - INTEGER - + I,J,JJ,JU,KP1 - LOGICAL - + CB,CQTY,CQY,CR,CXB - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DDOT - EXTERNAL - + DDOT - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DAXPY,DCOPY - -C...INTRINSIC FUNCTIONS - INTRINSIC - + MIN0,MOD - - -C***FIRST EXECUTABLE STATEMENT DQRSL - - - INFO = 0 - -C DETERMINE WHAT IS TO BE COMPUTED. - - CQY = JOB/10000 .NE. 0 - CQTY = MOD(JOB,10000) .NE. 0 - CB = MOD(JOB,1000)/100 .NE. 0 - CR = MOD(JOB,100)/10 .NE. 0 - CXB = MOD(JOB,10) .NE. 0 - JU = MIN0(K,N-1) - -C SPECIAL ACTION WHEN N=1. - - IF (JU .NE. 0) GO TO 40 - IF (CQY) QY(1) = Y(1) - IF (CQTY) QTY(1) = Y(1) - IF (CXB) XB(1) = Y(1) - IF (.NOT.CB) GO TO 30 - IF (X(1,1) .NE. 0.0D0) GO TO 10 - INFO = 1 - GO TO 20 - 10 CONTINUE - B(1) = Y(1)/X(1,1) - 20 CONTINUE - 30 CONTINUE - IF (CR) RSD(1) = 0.0D0 - GO TO 250 - 40 CONTINUE - -C SET UP TO COMPUTE QY OR QTY. - - IF (CQY) CALL DCOPY(N,Y,1,QY,1) - IF (CQTY) CALL DCOPY(N,Y,1,QTY,1) - IF (.NOT.CQY) GO TO 70 - -C COMPUTE QY. - - DO 60 JJ = 1, JU - J = JU - JJ + 1 - IF (QRAUX(J) .EQ. 0.0D0) GO TO 50 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - T = -DDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) - CALL DAXPY(N-J+1,T,X(J,J),1,QY(J),1) - X(J,J) = TEMP - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IF (.NOT.CQTY) GO TO 100 - -C COMPUTE TRANS(Q)*Y. - - DO 90 J = 1, JU - IF (QRAUX(J) .EQ. 0.0D0) GO TO 80 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - T = -DDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) - CALL DAXPY(N-J+1,T,X(J,J),1,QTY(J),1) - X(J,J) = TEMP - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - -C SET UP TO COMPUTE B, RSD, OR XB. - - IF (CB) CALL DCOPY(K,QTY,1,B,1) - KP1 = K + 1 - IF (CXB) CALL DCOPY(K,QTY,1,XB,1) - IF (CR .AND. K .LT. N) CALL DCOPY(N-K,QTY(KP1),1,RSD(KP1),1) - IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 - DO 110 I = KP1, N - XB(I) = 0.0D0 - 110 CONTINUE - 120 CONTINUE - IF (.NOT.CR) GO TO 140 - DO 130 I = 1, K - RSD(I) = 0.0D0 - 130 CONTINUE - 140 CONTINUE - IF (.NOT.CB) GO TO 190 - -C COMPUTE B. - - DO 170 JJ = 1, K - J = K - JJ + 1 - IF (X(J,J) .NE. 0.0D0) GO TO 150 - INFO = J -C ......EXIT - GO TO 180 - 150 CONTINUE - B(J) = B(J)/X(J,J) - IF (J .EQ. 1) GO TO 160 - T = -B(J) - CALL DAXPY(J-1,T,X(1,J),1,B,1) - 160 CONTINUE - 170 CONTINUE - 180 CONTINUE - 190 CONTINUE - IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 - -C COMPUTE RSD OR XB AS REQUIRED. - - DO 230 JJ = 1, JU - J = JU - JJ + 1 - IF (QRAUX(J) .EQ. 0.0D0) GO TO 220 - TEMP = X(J,J) - X(J,J) = QRAUX(J) - IF (.NOT.CR) GO TO 200 - T = -DDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) - CALL DAXPY(N-J+1,T,X(J,J),1,RSD(J),1) - 200 CONTINUE - IF (.NOT.CXB) GO TO 210 - T = -DDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) - CALL DAXPY(N-J+1,T,X(J,J),1,XB(J),1) - 210 CONTINUE - X(J,J) = TEMP - 220 CONTINUE - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN - END -*DTRCO - SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB) -C***BEGIN PROLOGUE DTRCO -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2A3 -C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, -C MATRIX,TRIANGULAR -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR -C MATRIX. -C***DESCRIPTION -C DTRCO ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR -C MATRIX. -C ON ENTRY -C T DOUBLE PRECISION(LDT,N) -C T CONTAINS THE TRIANGULAR MATRIX. THE ZERO -C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND -C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE -C USED TO STORE OTHER INFORMATION. -C LDT INTEGER -C LDT IS THE LEADING DIMENSION OF THE ARRAY T. -C N INTEGER -C N IS THE ORDER OF THE SYSTEM. -C JOB INTEGER -C = 0 T IS LOWER TRIANGULAR. -C = NONZERO T IS UPPER TRIANGULAR. -C ON RETURN -C RCOND DOUBLE PRECISION -C AN ESTIMATE OF THE RECIPROCAL CONDITION OF T . -C FOR THE SYSTEM T*X = B , RELATIVE PERTURBATIONS -C IN T AND B OF SIZE EPSILON MAY CAUSE -C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . -C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION -C 1.0 + RCOND .EQ. 1.0 -C IS TRUE, THEN T MAY BE SINGULAR TO WORKING -C PRECISION. IN PARTICULAR, RCOND IS ZERO IF -C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE -C UNDERFLOWS. -C Z DOUBLE PRECISION(N) -C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. -C IF T IS CLOSE TO A SINGULAR MATRIX, THEN Z IS -C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C LINPACK. THIS VERSION DATED 08/14/78 . -C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DASUM,DAXPY,DSCAL -C***END PROLOGUE DTRCO - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + RCOND - INTEGER - + JOB,LDT,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + T(LDT,*),Z(*) - -C...LOCAL SCALARS - DOUBLE PRECISION - + EK,S,SM,TNORM,W,WK,WKM,YNORM - INTEGER - + I1,J,J1,J2,K,KK,L - LOGICAL - + LOWER - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DASUM - EXTERNAL - + DASUM - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DAXPY,DSCAL - -C...INTRINSIC FUNCTIONS - INTRINSIC - + DABS,DMAX1,DSIGN - - -C***FIRST EXECUTABLE STATEMENT DTRCO - - - LOWER = JOB .EQ. 0 - -C COMPUTE 1-NORM OF T - - TNORM = 0.0D0 - DO 10 J = 1, N - L = J - IF (LOWER) L = N + 1 - J - I1 = 1 - IF (LOWER) I1 = J - TNORM = DMAX1(TNORM,DASUM(L,T(I1,J),1)) - 10 CONTINUE - -C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . -C TRANS(T) IS THE TRANSPOSE OF T . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF Y . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. - -C SOLVE TRANS(T)*Y = E - - EK = 1.0D0 - DO 20 J = 1, N - Z(J) = 0.0D0 - 20 CONTINUE - DO 100 KK = 1, N - K = KK - IF (LOWER) K = N + 1 - KK - IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) - IF (DABS(EK-Z(K)) .LE. DABS(T(K,K))) GO TO 30 - S = DABS(T(K,K))/DABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = DABS(WK) - SM = DABS(WKM) - IF (T(K,K) .EQ. 0.0D0) GO TO 40 - WK = WK/T(K,K) - WKM = WKM/T(K,K) - GO TO 50 - 40 CONTINUE - WK = 1.0D0 - WKM = 1.0D0 - 50 CONTINUE - IF (KK .EQ. N) GO TO 90 - J1 = K + 1 - IF (LOWER) J1 = 1 - J2 = N - IF (LOWER) J2 = K - 1 - DO 60 J = J1, J2 - SM = SM + DABS(Z(J)+WKM*T(K,J)) - Z(J) = Z(J) + WK*T(K,J) - S = S + DABS(Z(J)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - W = WKM - WK - WK = WKM - DO 70 J = J1, J2 - Z(J) = Z(J) + W*T(K,J) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - - YNORM = 1.0D0 - -C SOLVE T*Z = Y - - DO 130 KK = 1, N - K = N + 1 - KK - IF (LOWER) K = KK - IF (DABS(Z(K)) .LE. DABS(T(K,K))) GO TO 110 - S = DABS(T(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 110 CONTINUE - IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K) - IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - I1 = 1 - IF (LOWER) I1 = K + 1 - IF (KK .GE. N) GO TO 120 - W = -Z(K) - CALL DAXPY(N-KK,W,T(I1,K),1,Z(I1),1) - 120 CONTINUE - 130 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - - IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM - IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0 - RETURN - END -*DTRSL - SUBROUTINE DTRSL(T,LDT,N,B,JOB,INFO) -C***BEGIN PROLOGUE DTRSL -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2A3 -C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, -C TRIANGULAR -C***AUTHOR STEWART, G. W., (U. OF MARYLAND) -C***PURPOSE SOLVES SYSTEMS OF THE FORM T*X=B OR TRANS(T)*X=B WHERE T -C IS A TRIANGULAR MATRIX OF ORDER N. -C***DESCRIPTION -C DTRSL SOLVES SYSTEMS OF THE FORM -C T * X = B -C OR -C TRANS(T) * X = B -C WHERE T IS A TRIANGULAR MATRIX OF ORDER N. HERE TRANS(T) -C DENOTES THE TRANSPOSE OF THE MATRIX T. -C ON ENTRY -C T DOUBLE PRECISION(LDT,N) -C T CONTAINS THE MATRIX OF THE SYSTEM. THE ZERO -C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND -C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE -C USED TO STORE OTHER INFORMATION. -C LDT INTEGER -C LDT IS THE LEADING DIMENSION OF THE ARRAY T. -C N INTEGER -C N IS THE ORDER OF THE SYSTEM. -C B DOUBLE PRECISION(N). -C B CONTAINS THE RIGHT HAND SIDE OF THE SYSTEM. -C JOB INTEGER -C JOB SPECIFIES WHAT KIND OF SYSTEM IS TO BE SOLVED. -C IF JOB IS -C 00 SOLVE T*X=B, T LOWER TRIANGULAR, -C 01 SOLVE T*X=B, T UPPER TRIANGULAR, -C 10 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, -C 11 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. -C ON RETURN -C B B CONTAINS THE SOLUTION, IF INFO .EQ. 0. -C OTHERWISE B IS UNALTERED. -C INFO INTEGER -C INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR. -C OTHERWISE INFO CONTAINS THE INDEX OF -C THE FIRST ZERO DIAGONAL ELEMENT OF T. -C LINPACK. THIS VERSION DATED 08/14/78 . -C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DDOT -C***END PROLOGUE DTRSL - -C...SCALAR ARGUMENTS - INTEGER - + INFO,JOB,LDT,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + B(*),T(LDT,*) - -C...LOCAL SCALARS - DOUBLE PRECISION - + TEMP - INTEGER - + CASE,J,JJ - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DDOT - EXTERNAL - + DDOT - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DAXPY - -C...INTRINSIC FUNCTIONS - INTRINSIC - + MOD - - -C***FIRST EXECUTABLE STATEMENT DTRSL - - -C BEGIN BLOCK PERMITTING ...EXITS TO 150 - -C CHECK FOR ZERO DIAGONAL ELEMENTS. - - DO 10 INFO = 1, N -C ......EXIT - IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150 - 10 CONTINUE - INFO = 0 - -C DETERMINE THE TASK AND GO TO IT. - - CASE = 1 - IF (MOD(JOB,10) .NE. 0) CASE = 2 - IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 - GO TO (20,50,80,110), CASE - -C SOLVE T*X=B FOR T LOWER TRIANGULAR - - 20 CONTINUE - B(1) = B(1)/T(1,1) - IF (N .LT. 2) GO TO 40 - DO 30 J = 2, N - TEMP = -B(J-1) - CALL DAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) - B(J) = B(J)/T(J,J) - 30 CONTINUE - 40 CONTINUE - GO TO 140 - -C SOLVE T*X=B FOR T UPPER TRIANGULAR. - - 50 CONTINUE - B(N) = B(N)/T(N,N) - IF (N .LT. 2) GO TO 70 - DO 60 JJ = 2, N - J = N - JJ + 1 - TEMP = -B(J+1) - CALL DAXPY(J,TEMP,T(1,J+1),1,B(1),1) - B(J) = B(J)/T(J,J) - 60 CONTINUE - 70 CONTINUE - GO TO 140 - -C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. - - 80 CONTINUE - B(N) = B(N)/T(N,N) - IF (N .LT. 2) GO TO 100 - DO 90 JJ = 2, N - J = N - JJ + 1 - B(J) = B(J) - DDOT(JJ-1,T(J+1,J),1,B(J+1),1) - B(J) = B(J)/T(J,J) - 90 CONTINUE - 100 CONTINUE - GO TO 140 - -C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. - - 110 CONTINUE - B(1) = B(1)/T(1,1) - IF (N .LT. 2) GO TO 130 - DO 120 J = 2, N - B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1) - B(J) = B(J)/T(J,J) - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - RETURN - END diff --git a/scipy/odr/odrpack/d_mprec.f b/scipy/odr/odrpack/d_mprec.f deleted file mode 100644 index 464c4bad3bd0..000000000000 --- a/scipy/odr/odrpack/d_mprec.f +++ /dev/null @@ -1,203 +0,0 @@ -*DMPREC - DOUBLE PRECISION FUNCTION DMPREC() -C***BEGIN PROLOGUE DPREC -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE DETERMINE MACHINE PRECISION FOR TARGET MACHINE AND COMPILER -C ASSUMING FLOATING-POINT NUMBERS ARE REPRESENTED IN THE -C T-DIGIT, BASE-B FORM -C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, AND -C 0 .LT. X(1). -C TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE, -C EITHER -C ACTIVATE THE DESIRED SET OF DATA STATEMENTS BY -C REMOVING THE C FROM COLUMN 1 -C OR -C SET B, TD AND TS USING I1MACH BY ACTIVATING -C THE DECLARATION STATEMENTS FOR I1MACH -C AND THE STATEMENTS PRECEDING THE FIRST -C EXECUTABLE STATEMENT BELOW. -C***END PROLOGUE DPREC - -C...LOCAL SCALARS - DOUBLE PRECISION - + B - INTEGER - + TD,TS - -C...EXTERNAL FUNCTIONS -C INTEGER -C + I1MACH -C EXTERNAL -C + I1MACH - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) - -C DOUBLE PRECISION B -C THE BASE OF THE TARGET MACHINE. -C (MAY BE DEFINED USING I1MACH(10).) -C INTEGER TD -C THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION. -C (MAY BE DEFINED USING I1MACH(14).) -C INTEGER TS -C THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION. -C (MAY BE DEFINED USING I1MACH(11).) - - -C MACHINE CONSTANTS FOR COMPUTERS FOLLOWING IEEE ARITHMETIC STANDARD -C (E.G., MOTOROLA 68000 BASED MACHINES SUCH AS SUN AND SPARC -C WORKSTATIONS, AND AT&T PC 7300; AND 8087 BASED MICROS SUCH AS THE -C IBM PC AND THE AT&T 6300). - DATA B / 2 / - DATA TS / 24 / - DATA TD / 53 / - -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. -C DATA B / 2 / -C DATA TS / 24 / -C DATA TD / 60 / - -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C THE BURROUGHS 6700/7700 SYSTEMS -C DATA B / 8 / -C DATA TS / 13 / -C DATA TD / 26 / - -C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN5 COMPILER) -C THE CYBER 170/180 SERIES UNDER NOS -C DATA B / 2 / -C DATA TS / 48 / -C DATA TD / 96 / - -C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN COMPILER) -C THE CYBER 170/180 SERIES UNDER NOS/VE -C THE CYBER 200 SERIES -C DATA B / 2 / -C DATA TS / 47 / -C DATA TD / 94 / - -C MACHINE CONSTANTS FOR THE CRAY -C DATA B / 2 / -C DATA TS / 47 / -C DATA TD / 94 / - -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C DATA B / 16 / -C DATA TS / 6 / -C DATA TD / 14 / - -C MACHINE CONSTANTS FOR THE HARRIS COMPUTER -C DATA B / 2 / -C DATA TS / 23 / -C DATA TD / 38 / - -C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 -C THE HONEYWELL 600/6000 SERIES -C DATA B / 2 / -C DATA TS / 27 / -C DATA TD / 63 / - -C MACHINE CONSTANTS FOR THE HP 2100 -C (3 WORD DOUBLE PRECISION OPTION WITH FTN4) -C DATA B / 2 / -C DATA TS / 23 / -C DATA TD / 39 / - -C MACHINE CONSTANTS FOR THE HP 2100 -C (4 WORD DOUBLE PRECISION OPTION WITH FTN4) -C DATA B / 2 / -C DATA TS / 23 / -C DATA TD / 55 / - -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES -C DATA B / 16 / -C DATA TS / 6 / -C DATA TD / 14 / - -C MACHINE CONSTANTS FOR THE IBM PC -C DATA B / 2 / -C DATA TS / 24 / -C DATA TD / 53 / - -C MACHINE CONSTANTS FOR THE INTERDATA (PERKIN ELMER) 7/32 -C INTERDATA (PERKIN ELMER) 8/32 -C DATA B / 16 / -C DATA TS / 6 / -C DATA TD / 14 / - -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). -C DATA B / 2 / -C DATA TS / 27 / -C DATA TD / 54 / - -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). -C DATA B / 2 / -C DATA TS / 27 / -C DATA TD / 62 / - -C MACHINE CONSTANTS FOR THE PDP-11 SYSTEM -C DATA B / 2 / -C DATA TS / 24 / -C DATA TD / 56 / - -C MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230 -C DATA B / 16 / -C DATA TS / 6 / -C DATA TD / 14 / - -C MACHINE CONSTANTS FOR THE PRIME 850 AND PRIME 4050 -C DATA B / 2 / -C DATA TS / 23 / -C DATA TD / 47 / - -C MACHINE CONSTANTS FOR THE SEL SYSTEMS 85/86 -C DATA B / 16 / -C DATA TS / 6 / -C DATA TD / 14 / - -C MACHINE CONSTANTS FOR SUN AND SPARC WORKSTATIONS -C DATA B / 2 / -C DATA TS / 24 / -C DATA TD / 53 / - -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES -C DATA B / 2 / -C DATA TS / 27 / -C DATA TD / 60 / - -C MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS COMPILER -C DATA B / 2 / -C DATA TS / 24 / -C DATA TD / 56 / - -C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITHOUT G_FLOATING -C DATA B / 2 / -C DATA TS / 24 / -C DATA TD / 56 / - -C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITH G_FLOATING -C DATA B / 2 / -C DATA TS / 24 / -C DATA TD / 53 / - -C MACHINE CONSTANTS FOR THE XEROX SIGMA 5/7/9 -C DATA B / 16 / -C DATA TS / 6 / -C DATA TD / 14 / - - -C***FIRST EXECUTABLE STATEMENT DMPREC - - -C B = I1MACH(10) -C TS = I1MACH(11) -C TD = I1MACH(14) - - DMPREC = B ** (1-TD) - - RETURN - - END diff --git a/scipy/odr/odrpack/d_odr.f b/scipy/odr/odrpack/d_odr.f deleted file mode 100644 index 992c2f4c7de5..000000000000 --- a/scipy/odr/odrpack/d_odr.f +++ /dev/null @@ -1,10985 +0,0 @@ -*DODR - SUBROUTINE DODR - + (FCN, - + N,M,NP,NQ, - + BETA, - + Y,LDY,X,LDX, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, - + JOB, - + IPRINT,LUNERR,LUNRPT, - + WORK,LWORK,IWORK,LIWORK, - + INFO) -C***BEGIN PROLOGUE DODR -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***CATEGORY NO. G2E,I1B1 -C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, -C NONLINEAR LEAST SQUARES, -C MEASUREMENT ERROR MODELS, -C ERRORS IN VARIABLES -C***AUTHOR BOGGS, PAUL T. -C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION -C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY -C GAITHERSBURG, MD 20899 -C BYRD, RICHARD H. -C DEPARTMENT OF COMPUTER SCIENCE -C UNIVERSITY OF COLORADO, BOULDER, CO 80309 -C ROGERS, JANET E. -C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION -C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY -C BOULDER, CO 80303-3328 -C SCHNABEL, ROBERT B. -C DEPARTMENT OF COMPUTER SCIENCE -C UNIVERSITY OF COLORADO, BOULDER, CO 80309 -C AND -C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION -C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY -C BOULDER, CO 80303-3328 -C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING -C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE -C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST -C SQUARES (OLS) SOLUTION (SHORT CALL STATEMENT) -C***DESCRIPTION -C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. -C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND -C R. B. SCHNABEL (1989), -C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED -C ORTHOGONAL DISTANCE REGRESSION," -C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. -C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND -C R. B. SCHNABEL (1992), -C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, -C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," -C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY -C INTERNAL REPORT NUMBER 92-4834. -C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), -C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR -C ORTHOGONAL DISTANCE REGRESSION," -C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. -C***ROUTINES CALLED DODCNT -C***END PROLOGUE DODR - -C...SCALAR ARGUMENTS - INTEGER - + INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK, - + M,N,NDIGIT,NP,NQ - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), - + X(LDX,M),Y(LDY,NQ) - INTEGER - + IWORK(LIWORK) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + NEGONE,PARTOL,SSTOL,TAUFAC,ZERO - INTEGER - + IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT - LOGICAL - + SHORT - -C...LOCAL ARRAYS - DOUBLE PRECISION - + SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1) - INTEGER - + IFIXB(1),IFIXX(1,1) - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DODCNT - -C...DATA STATEMENTS - DATA - + NEGONE,ZERO - + /-1.0D0,0.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C IPRINT: THE PRINT CONTROL VARIABLE. -C IWORK: THE INTEGER WORK SPACE. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LIWORK: THE LENGTH OF VECTOR IWORK. -C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. -C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. -C LWORK: THE LENGTH OF VECTOR WORK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C N: THE NUMBER OF OBSERVATIONS. -C NEGONE: THE VALUE -1.0D0. -C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS -C SUPPLIED BY THE USER. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. -C SCLB: THE SCALING VALUES FOR BETA. -C SCLD: THE SCALING VALUES FOR DELTA. -C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO BETA. -C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED -C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL -C (SHORT=.FALSE.). -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C WD: THE DELTA WEIGHTS. -C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. -C WE: THE EPSILON WEIGHTS. -C WORK: THE DOUBLE PRECISION WORK SPACE. -C X: THE EXPLANATORY VARIABLE. -C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. - - -C***FIRST EXECUTABLE STATEMENT DODR - - -C INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES - - IFIXB(1) = -1 - IFIXX(1,1) = -1 - LDIFX = 1 - NDIGIT = -1 - TAUFAC = NEGONE - SSTOL = NEGONE - PARTOL = NEGONE - MAXIT = -1 - STPB(1) = NEGONE - STPD(1,1) = NEGONE - LDSTPD = 1 - SCLB(1) = NEGONE - SCLD(1,1) = NEGONE - LDSCLD = 1 - - SHORT = .TRUE. - - IF (WD(1,1,1).NE.ZERO) THEN - CALL DODCNT - + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, - + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, - + IPRINT,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, - + WORK,LWORK,IWORK,LIWORK, - + INFO) - ELSE - WD1(1,1,1) = NEGONE - CALL DODCNT - + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, - + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, - + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, - + IPRINT,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, - + WORK,LWORK,IWORK,LIWORK, - + INFO) - END IF - - RETURN - - END -*DODRC - SUBROUTINE DODRC - + (FCN, - + N,M,NP,NQ, - + BETA, - + Y,LDY,X,LDX, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, - + IFIXB,IFIXX,LDIFX, - + JOB,NDIGIT,TAUFAC, - + SSTOL,PARTOL,MAXIT, - + IPRINT,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, - + SCLB,SCLD,LDSCLD, - + WORK,LWORK,IWORK,LIWORK, - + INFO) -C***BEGIN PROLOGUE DODRC -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***CATEGORY NO. G2E,I1B1 -C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, -C NONLINEAR LEAST SQUARES, -C MEASUREMENT ERROR MODELS, -C ERRORS IN VARIABLES -C***AUTHOR BOGGS, PAUL T. -C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION -C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY -C GAITHERSBURG, MD 20899 -C BYRD, RICHARD H. -C DEPARTMENT OF COMPUTER SCIENCE -C UNIVERSITY OF COLORADO, BOULDER, CO 80309 -C ROGERS, JANET E. -C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION -C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY -C BOULDER, CO 80303-3328 -C SCHNABEL, ROBERT B. -C DEPARTMENT OF COMPUTER SCIENCE -C UNIVERSITY OF COLORADO, BOULDER, CO 80309 -C AND -C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION -C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY -C BOULDER, CO 80303-3328 -C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING -C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE -C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST -C SQUARES (OLS) SOLUTION (LONG CALL STATEMENT) -C***DESCRIPTION -C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. -C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND -C R. B. SCHNABEL (1989), -C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED -C ORTHOGONAL DISTANCE REGRESSION," -C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. -C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND -C R. B. SCHNABEL (1992), -C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, -C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," -C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY -C INTERNAL REPORT NUMBER 92-4834. -C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), -C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR -C ORTHOGONAL DISTANCE REGRESSION," -C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. -C***ROUTINES CALLED DODCNT -C***END PROLOGUE DODRC - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + PARTOL,SSTOL,TAUFAC - INTEGER - + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, - + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), - + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), - + X(LDX,M),Y(LDY,NQ) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + NEGONE,ZERO - LOGICAL - + SHORT - -C...LOCAL ARRAYS - DOUBLE PRECISION - + WD1(1,1,1) - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DODCNT - -C...DATA STATEMENTS - DATA - + NEGONE,ZERO - + /-1.0D0,0.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C IPRINT: THE PRINT CONTROL VARIABLE. -C IWORK: THE INTEGER WORK SPACE. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LIWORK: THE LENGTH OF VECTOR IWORK. -C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. -C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. -C LWORK: THE LENGTH OF VECTOR WORK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C N: THE NUMBER OF OBSERVATIONS. -C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS -C SUPPLIED BY THE USER. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. -C SCLB: THE SCALING VALUES FOR BETA. -C SCLD: THE SCALING VALUES FOR DELTA. -C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO BETA. -C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED -C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL -C (SHORT=.FALSE.). -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C WD: THE DELTA WEIGHTS. -C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. -C WE: THE EPSILON WEIGHTS. -C WORK: THE DOUBLE PRECISION WORK SPACE. -C X: THE EXPLANATORY VARIABLE. -C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. - - -C***FIRST EXECUTABLE STATEMENT DODRC - - - SHORT = .FALSE. - - IF (WD(1,1,1).NE.ZERO) THEN - CALL DODCNT - + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, - + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, - + IPRINT,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, - + WORK,LWORK,IWORK,LIWORK, - + INFO) - ELSE - WD1(1,1,1) = NEGONE - CALL DODCNT - + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, - + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, - + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, - + IPRINT,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, - + WORK,LWORK,IWORK,LIWORK, - + INFO) - END IF - - RETURN - - END -*DACCES - SUBROUTINE DACCES - + (N,M,NP,NQ,LDWE,LD2WE, - + WORK,LWORK,IWORK,LIWORK, - + ACCESS,ISODR, - + JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, - + NNZW,NPP, - + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, - + LUNRPT,IPR1,IPR2,IPR2F,IPR3, - + WSS,RVAR,IDF, - + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, - + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) -C***BEGIN PROLOGUE DACCES -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DIWINF,DWINF -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS -C***END PROLOGUE DACESS - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND, - + RNORMS,RVAR,SSTOL,TAU,TAUFAC - INTEGER - + IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT, - + LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV, - + NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV, - + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 - LOGICAL - + ACCESS,ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + WORK(LWORK),WSS(3) - INTEGER - + IWORK(LIWORK) - -C...LOCAL SCALARS - INTEGER - + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I, - + DELTAI,DELTNI,DELTSI,DIFFI,EPSI, - + EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, - + IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI, - + MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI, - + NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, - + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, - + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, - + WSSI,WSSDEI,WSSEPI,XPLUSI -C...EXTERNAL SUBROUTINES - EXTERNAL - + DIWINF,DWINF - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE -C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN -C THEM (ACCESS=FALSE). -C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. -C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. -C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. -C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. -C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. -C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. -C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. -C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. -C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. -C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. -C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. -C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. -C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. -C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. -C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. -C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. -C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. -C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. -C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. -C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF -C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE -C NUMBER OF PARAMETERS BEING ESTIMATED. -C IDFI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE IDF. -C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS. -C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. -C IPR1: THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, -C WHICH CONTROLS THE INITIAL SUMMARY REPORT. -C IPR2: THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, -C WHICH CONTROLS THE ITERATION REPORTS. -C IPR2F: THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, -C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. -C IPR3: THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, -C WHICH CONTROLS THE FINAL SUMMARY REPORT. -C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. -C IPRINT: THE PRINT CONTROL VARIABLE. -C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. -C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS TO BE -C FOUND BY ODR (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. -C IWORK: THE INTEGER WORK SPACE. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. -C JPVT: THE PIVOT VECTOR. -C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE JPVT. -C LDTTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE LDTT. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LIWORK: THE LENGTH OF VECTOR IWORK. -C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. -C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. -C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. -C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. -C LWORK: THE LENGTH OF VECTOR WORK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. -C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. -C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. -C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. -C NITER: THE NUMBER OF ITERATIONS TAKEN. -C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. -C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. -C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. -C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. -C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPP: THE NUMBER OF FUNCTION PARAMETERS ACTUALLY ESTIMATED. -C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. -C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. -C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER -C ITERATION. -C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. -C OMEGA: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. -C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. -C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. -C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. -C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. -C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. -C PRERS: THE SAVED PREDICTED RELATIVE REDUCTION IN THE -C SUM-OF-SQUARES. -C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. -C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. -C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. -C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. -C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. -C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART -C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). -C RNORMS: THE NORM OF THE SAVED WEIGHTED EPSILONS AND DELTAS. -C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. -C RVAR: THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. -C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. -C SCLB: THE SCALING VALUES USED FOR BETA. -C SCLD: THE SCALING VALUES USED FOR DELTA. -C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. -C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. -C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED -C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG- -C CALL (SHORT=FALSE). -C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. -C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. -C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. -C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. -C TAU: THE TRUST REGION DIAMETER. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. -C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. -C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. -C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. -C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. -C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. -C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. -C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. -C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. -C WORK: THE DOUBLE PRECISION WORK SPACE. -C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. -C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. -C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. -C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. -C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. -C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. -C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. -C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. -C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. -C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. -C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. -C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. -C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. -C WSS: THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, -C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS, AND -C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. -C WSSI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(1). -C WSSDEI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(2). -C WSSEPI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(3). -C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. - - -C***FIRST EXECUTABLE STATEMENT DACCES - - -C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE - - CALL DIWINF(M,NP,NQ, - + MSGB,MSGD,JPVTI,ISTOPI, - + NNZWI,NPPI,IDFI, - + JOBI,IPRINI,LUNERI,LUNRPI, - + NROWI,NTOLI,NETAI, - + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, - + LIWKMN) - -C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE - - CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, - + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, - + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, - + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, - + PARTLI,SSTOLI,TAUFCI,EPSMAI, - + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, - + FSI,FJACBI,WE1I,DIFFI, - + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, - + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, - + LWKMN) - - IF (ACCESS) THEN - -C SET STARTING LOCATIONS FOR WORK VECTORS - - JPVT = JPVTI - OMEGA = OMEGAI - QRAUX = QRAUXI - SD = SDI - VCV = VCVI - U = UI - WRK1 = WRK1I - WRK2 = WRK2I - WRK3 = WRK3I - WRK4 = WRK4I - WRK5 = WRK5I - WRK6 = WRK6I - -C ACCESS VALUES FROM THE WORK VECTORS - - ACTRS = WORK(ACTRSI) - ALPHA = WORK(ALPHAI) - ETA = WORK(ETAI) - OLMAVG = WORK(OLMAVI) - PARTOL = WORK(PARTLI) - PNORM = WORK(PNORMI) - PRERS = WORK(PRERSI) - RCOND = WORK(RCONDI) - WSS(1) = WORK(WSSI) - WSS(2) = WORK(WSSDEI) - WSS(3) = WORK(WSSEPI) - RVAR = WORK(RVARI) - RNORMS = WORK(RNORSI) - SSTOL = WORK(SSTOLI) - TAU = WORK(TAUI) - TAUFAC = WORK(TAUFCI) - - NETA = IWORK(NETAI) - IRANK = IWORK(IRANKI) - JOB = IWORK(JOBI) - LUNRPT = IWORK(LUNRPI) - MAXIT = IWORK(MAXITI) - NFEV = IWORK(NFEVI) - NITER = IWORK(NITERI) - NJEV = IWORK(NJEVI) - NNZW = IWORK(NNZWI) - NPP = IWORK(NPPI) - IDF = IWORK(IDFI) - INT2 = IWORK(INT2I) - -C SET UP PRINT CONTROL VARIABLES - - IPRINT = IWORK(IPRINI) - - IPR1 = MOD(IPRINT,10000)/1000 - IPR2 = MOD(IPRINT,1000)/100 - IPR2F = MOD(IPRINT,100)/10 - IPR3 = MOD(IPRINT,10) - - ELSE - -C STORE VALUES INTO THE WORK VECTORS - - WORK(ACTRSI) = ACTRS - WORK(ALPHAI) = ALPHA - WORK(OLMAVI) = OLMAVG - WORK(PARTLI) = PARTOL - WORK(PNORMI) = PNORM - WORK(PRERSI) = PRERS - WORK(RCONDI) = RCOND - WORK(WSSI) = WSS(1) - WORK(WSSDEI) = WSS(2) - WORK(WSSEPI) = WSS(3) - WORK(RVARI) = RVAR - WORK(RNORSI) = RNORMS - WORK(SSTOLI) = SSTOL - WORK(TAUI) = TAU - - IWORK(IRANKI) = IRANK - IWORK(ISTOPI) = ISTOP - IWORK(NFEVI) = NFEV - IWORK(NITERI) = NITER - IWORK(NJEVI) = NJEV - IWORK(IDFI) = IDF - IWORK(INT2I) = INT2 - END IF - - RETURN - END -*DESUBI - SUBROUTINE DESUBI - + (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E) -C***BEGIN PROLOGUE DESUBI -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DZERO -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE COMPUTE E = WD + ALPHA*TT**2 -C***END PROLOGUE DESUBI - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + ALPHA - INTEGER - + LDTT,LDWD,LD2WD,M,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M) - -C...LOCAL SCALARS - DOUBLE PRECISION - + ZERO - INTEGER - + I,J,J1,J2 - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DZERO - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. -C E: THE VALUE OF THE ARRAY E = WD + ALPHA*TT**2 -C I: AN INDEXING VARIABLE. -C J: AN INDEXING VARIABLE. -C J1: AN INDEXING VARIABLE. -C J2: AN INDEXING VARIABLE. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NP: THE NUMBER OF RESPONSES PER OBSERVATION. -C TT: THE SCALING VALUES USED FOR DELTA. -C WD: THE SQUARED DELTA WEIGHTS, D**2. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DESUBI - - -C N.B. THE LOCATIONS OF WD AND TT ACCESSED DEPEND ON THE VALUE -C OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSIONS -C OF THE MULTIPLY SUBSCRIPTED ARRAYS. - - IF (N.EQ.0 .OR. M.EQ.0) RETURN - - IF (WD(1,1,1).GE.ZERO) THEN - IF (LDWD.GE.N) THEN -C THE ELEMENTS OF WD HAVE BEEN INDIVIDUALLY SPECIFIED - - IF (LD2WD.EQ.1) THEN -C THE ARRAYS STORED IN WD ARE DIAGONAL - CALL DZERO(M,M,E,M) - DO 10 J=1,M - E(J,J) = WD(I,1,J) - 10 CONTINUE - ELSE -C THE ARRAYS STORED IN WD ARE FULL POSITIVE SEMIDEFINITE MATRICES - DO 30 J1=1,M - DO 20 J2=1,M - E(J1,J2) = WD(I,J1,J2) - 20 CONTINUE - 30 CONTINUE - END IF - - IF (TT(1,1).GT.ZERO) THEN - IF (LDTT.GE.N) THEN - DO 110 J=1,M - E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 - 110 CONTINUE - ELSE - DO 120 J=1,M - E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 - 120 CONTINUE - END IF - ELSE - DO 130 J=1,M - E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 - 130 CONTINUE - END IF - ELSE -C WD IS AN M BY M MATRIX - - IF (LD2WD.EQ.1) THEN -C THE ARRAY STORED IN WD IS DIAGONAL - CALL DZERO(M,M,E,M) - DO 140 J=1,M - E(J,J) = WD(1,1,J) - 140 CONTINUE - ELSE -C THE ARRAY STORED IN WD IS A FULL POSITIVE SEMIDEFINITE MATRICES - DO 160 J1=1,M - DO 150 J2=1,M - E(J1,J2) = WD(1,J1,J2) - 150 CONTINUE - 160 CONTINUE - END IF - - IF (TT(1,1).GT.ZERO) THEN - IF (LDTT.GE.N) THEN - DO 210 J=1,M - E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 - 210 CONTINUE - ELSE - DO 220 J=1,M - E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 - 220 CONTINUE - END IF - ELSE - DO 230 J=1,M - E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 - 230 CONTINUE - END IF - END IF - ELSE -C WD IS A DIAGONAL MATRIX WITH ELEMENTS ABS(WD(1,1,1)) - CALL DZERO(M,M,E,M) - IF (TT(1,1).GT.ZERO) THEN - IF (LDTT.GE.N) THEN - DO 310 J=1,M - E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2 - 310 CONTINUE - ELSE - DO 320 J=1,M - E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2 - 320 CONTINUE - END IF - ELSE - DO 330 J=1,M - E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2 - 330 CONTINUE - END IF - END IF - - RETURN - END -*DETAF - SUBROUTINE DETAF - + (FCN, - + N,M,NP,NQ, - + XPLUSD,BETA,EPSMAC,NROW, - + PARTMP,PV0, - + IFIXB,IFIXX,LDIFX, - + ISTOP,NFEV,ETA,NETA, - + WRK1,WRK2,WRK6,WRK7) -C***BEGIN PROLOGUE DETAF -C***REFER TO DODR,DODRC -C***ROUTINES CALLED FCN -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS -C (ADAPTED FROM STARPAC SUBROUTINE ETAFUN) -C***END PROLOGUE DETAF - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + EPSMAC,ETA - INTEGER - + ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),PARTMP(NP),PV0(N,NQ), - + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + A,B,FAC,HUNDRD,ONE,P1,P2,P5,STP,TWO,ZERO - INTEGER - + J,K,L - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,INT,LOG10,MAX,SQRT - -C...DATA STATEMENTS - DATA - + ZERO,P1,P2,P5,ONE,TWO,HUNDRD - + /0.0D0,0.1D0,0.2D0,0.5D0,1.0D0,2.0D0,1.0D2/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C A: PARAMETERS OF THE LOCAL FIT. -C B: PARAMETERS OF THE LOCAL FIT. -C BETA: THE FUNCTION PARAMETERS. -C EPSMAC: THE VALUE OF MACHINE PRECISION. -C ETA: THE NOISE IN THE MODEL RESULTS. -C FAC: A FACTOR USED IN THE COMPUTATIONS. -C HUNDRD: THE VALUE 1.0D2. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C J: AN INDEX VARIABLE. -C K: AN INDEX VARIABLE. -C L: AN INDEX VARIABLE. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. -C ONE: THE VALUE 1.0D0. -C P1: THE VALUE 0.1D0. -C P2: THE VALUE 0.2D0. -C P5: THE VALUE 0.5D0. -C PARTMP: THE MODEL PARAMETERS. -C PV0: THE ORIGINAL PREDICTED VALUES. -C STP: A SMALL VALUE USED TO PERTURB THE PARAMETERS. -C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. -C WRK7: A WORK ARRAY OF (5 BY NQ) ELEMENTS. -C XPLUSD: THE VALUES OF X + DELTA. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DETAF - - - STP = HUNDRD*EPSMAC - ETA = EPSMAC - - DO 40 J=-2,2 - IF (J.EQ.0) THEN - DO 10 L=1,NQ - WRK7(J,L) = PV0(NROW,L) - 10 CONTINUE - ELSE - DO 20 K=1,NP - IF (IFIXB(1).LT.0) THEN - PARTMP(K) = BETA(K) + J*STP*BETA(K) - ELSE IF (IFIXB(K).NE.0) THEN - PARTMP(K) = BETA(K) + J*STP*BETA(K) - ELSE - PARTMP(K) = BETA(K) - END IF - 20 CONTINUE - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + PARTMP,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 003,WRK2,WRK6,WRK1,ISTOP) - IF (ISTOP.NE.0) THEN - RETURN - ELSE - NFEV = NFEV + 1 - END IF - DO 30 L=1,NQ - WRK7(J,L) = WRK2(NROW,L) - 30 CONTINUE - END IF - 40 CONTINUE - - DO 100 L=1,NQ - A = ZERO - B = ZERO - DO 50 J=-2,2 - A = A + WRK7(J,L) - B = B + J*WRK7(J,L) - 50 CONTINUE - A = P2*A - B = P1*B - IF ((WRK7(0,L).NE.ZERO) .AND. - + (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN - FAC = ONE/ABS(WRK7(0,L)) - ELSE - FAC = ONE - END IF - DO 60 J=-2,2 - WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC) - ETA = MAX(WRK7(J,L),ETA) - 60 CONTINUE - 100 CONTINUE - NETA = MAX(TWO,P5-LOG10(ETA)) - - RETURN - END -*DEVJAC - SUBROUTINE DEVJAC - + (FCN, - + ANAJAC,CDJAC, - + N,M,NP,NQ, - + BETAC,BETA,STPB, - + IFIXB,IFIXX,LDIFX, - + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, - + SSF,TT,LDTT,NETA,FN, - + STP,WRK1,WRK2,WRK3,WRK6, - + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, - + NJEV,NFEV,ISTOP,INFO) -C***BEGIN PROLOGUE DEVJAC -C***REFER TO DODR,DODRC -C***ROUTINES CALLED FCN,DDOT,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA -C***END PROLOGUE DEVJAC - -C...SCALAR ARGUMENTS - INTEGER - + INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE, - + M,N,NETA,NFEV,NJEV,NP,NQ - LOGICAL - + ANAJAC,CDJAC,ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), - + FN(N,NQ),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), - + WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP), - + WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - INTEGER - + IDEVAL,J,K,K1,L - DOUBLE PRECISION - + ZERO - LOGICAL - + ERROR - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DDOT - EXTERNAL - + DDOT - -C...DATA STATEMENTS - DATA ZERO - + /0.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE -C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT -C (ANAJAC=TRUE). -C BETA: THE FUNCTION PARAMETERS. -C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. -C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE -C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD -C DIFFERENCES (CDJAC=FALSE). -C DELTA: THE ESTIMATED VALUES OF DELTA. -C ERROR: THE VARIABLE DESIGNATING WHETHER ODRPACK DETECTED NONZERO -C VALUES IN ARRAY DELTA IN THE OLS CASE, AND THUS WHETHER -C THE USER MAY HAVE OVERWRITTEN IMPORTANT INFORMATION -C BY COMPUTING FJACD IN THE OLS CASE. -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C FN: THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT POINT. -C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE -C PERFORMED BY USER-SUPPLIED SUBROUTINE FCN. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C ISTOP: THE VARIABLE DESIGNATING THAT THE USER WISHES THE -C COMPUTATIONS STOPPED. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR OLS (ISODR=FALSE). -C J: AN INDEXING VARIABLE. -C K: AN INDEXING VARIABLE. -C K1: AN INDEXING VARIABLE. -C L: AN INDEXING VARIABLE. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDWE: THE LEADING DIMENSION OF ARRAYS WE AND WE1. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LD2WE: THE SECOND DIMENSION OF ARRAYS WE AND WE1. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C SSF: THE SCALE USED FOR THE BETA'S. -C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO BETA. -C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C TT: THE SCALING VALUES USED FOR DELTA. -C WE1: THE SQUARE ROOTS OF THE EPSILON WEIGHTS IN ARRAY WE. -C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK3: A WORK ARRAY OF (NP) ELEMENTS. -C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. -C X: THE INDEPENDENT VARIABLE. -C XPLUSD: THE VALUES OF X + DELTA. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DEVJAC - - -C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA - - CALL DUNPAC(NP,BETAC,BETA,IFIXB) - -C COMPUTE XPLUSD = X + DELTA - - CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) - -C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND -C THE JACOBIAN WRT DELTA (FJACD) - - ISTOP = 0 - IF (ISODR) THEN - IDEVAL = 110 - ELSE - IDEVAL = 010 - END IF - IF (ANAJAC) THEN - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + IDEVAL,WRK2,FJACB,FJACD, - + ISTOP) - IF (ISTOP.NE.0) THEN - RETURN - ELSE - NJEV = NJEV+1 - END IF -C MAKE SURE FIXED ELEMENTS OF FJACD ARE ZERO - IF (ISODR) THEN - DO 10 L=1,NQ - CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N) - 10 CONTINUE - END IF - ELSE IF (CDJAC) THEN - CALL DJACCD(FCN, - + N,M,NP,NQ, - + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, - + STPB,STPD,LDSTPD, - + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, - + FJACB,ISODR,FJACD,NFEV,ISTOP) - ELSE - CALL DJACFD(FCN, - + N,M,NP,NQ, - + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, - + STPB,STPD,LDSTPD, - + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, - + FJACB,ISODR,FJACD,NFEV,ISTOP) - END IF - IF (ISTOP.LT.0) THEN - RETURN - ELSE IF (.NOT.ISODR) THEN -C TRY TO DETECT WHETHER THE USER HAS COMPUTED JFACD -C WITHIN FCN IN THE OLS CASE - ERROR = DDOT(N*M,DELTA,1,DELTA,1).NE.ZERO - IF (ERROR) THEN - INFO = 50300 - RETURN - END IF - END IF - -C WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS - - IF (IFIXB(1).LT.0) THEN - DO 20 K=1,NP - CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, - + FJACB(1,K,1),N*NP,FJACB(1,K,1),N*NP) - 20 CONTINUE - ELSE - K1 = 0 - DO 30 K=1,NP - IF (IFIXB(K).GE.1) THEN - K1 = K1 + 1 - CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, - + FJACB(1,K,1),N*NP,FJACB(1,K1,1),N*NP) - END IF - 30 CONTINUE - END IF - -C WEIGHT THE JACOBIAN'S WRT DELTA AS APPROPRIATE - - IF (ISODR) THEN - DO 40 J=1,M - CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, - + FJACD(1,J,1),N*M,FJACD(1,J,1),N*M) - 40 CONTINUE - END IF - - RETURN - END -*DFCTR - SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO) -C***BEGIN PROLOGUE DFCTR -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DDOT -C***DATE WRITTEN 910706 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE FACTOR THE POSITIVE (SEMI)DEFINITE MATRIX A USING A -C MODIFIED CHOLESKY FACTORIZATION -C (ADAPTED FROM LINPACK SUBROUTINE DPOFA) -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***END PROLOGUE DFCTR - -C...SCALAR ARGUMENTS - INTEGER INFO,LDA,N - LOGICAL OKSEMI - -C...ARRAY ARGUMENTS - DOUBLE PRECISION A(LDA,N) - -C...LOCAL SCALARS - DOUBLE PRECISION XI,S,T,TEN,ZERO - INTEGER J,K - -C...EXTERNAL FUNCTIONS - EXTERNAL DMPREC,DDOT - DOUBLE PRECISION DMPREC,DDOT - -C...INTRINSIC FUNCTIONS - INTRINSIC SQRT - -C...DATA STATEMENTS - DATA - + ZERO,TEN - + /0.0D0,10.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C A: THE ARRAY TO BE FACTORED. UPON RETURN, A CONTAINS THE -C UPPER TRIANGULAR MATRIX R SO THAT A = TRANS(R)*R -C WHERE THE STRICT LOWER TRIANGLE IS SET TO ZERO -C IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE. -C I: AN INDEXING VARIABLE. -C INFO: AN IDICATOR VARIABLE, WHERE IF -C INFO = 0 THEN FACTORIZATION WAS COMPLETED -C INFO = K SIGNALS AN ERROR CONDITION. THE LEADING MINOR -C OF ORDER K IS NOT POSITIVE (SEMI)DEFINITE. -C J: AN INDEXING VARIABLE. -C LDA: THE LEADING DIMENSION OF ARRAY A. -C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY A. -C OKSEMI: THE INDICATING WHETHER THE FACTORED ARRAY CAN BE POSITIVE -C SEMIDEFINITE (OKSEMI=TRUE) OR WHETHER IT MUST BE FOUND TO -C BE POSITIVE DEFINITE (OKSEMI=FALSE). -C TEN: THE VALUE 10.0D0. -C XI: A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DFCTR - - -C SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS. - XI = -TEN*DMPREC() - -C COMPUTE FACTORIZATION, STORING IN UPPER TRIANGULAR PORTION OF A - DO 20 J=1,N - INFO = J - S = ZERO - DO 10 K=1,J-1 - IF (A(K,K).EQ.ZERO) THEN - T = ZERO - ELSE - T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1) - T = T/A(K,K) - END IF - A(K,J) = T - S = S + T*T - 10 CONTINUE - S = A(J,J) - S -C ......EXIT - IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN - RETURN - ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN - RETURN - ELSE IF (S.LE.ZERO) THEN - A(J,J) = ZERO - ELSE - A(J,J) = SQRT(S) - END IF - 20 CONTINUE - INFO = 0 - -C ZERO OUT LOWER PORTION OF A - DO 40 J=2,N - DO 30 K=1,J-1 - A(J,K) = ZERO - 30 CONTINUE - 40 CONTINUE - - RETURN - END -*DFCTRW - SUBROUTINE DFCTRW - + (N,M,NQ,NPP, - + ISODR, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, - + WRK0,WRK4, - + WE1,NNZW,INFO) -C***BEGIN PROLOGUE DFCTRW -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DFCTR -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING -C NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE -C ODRPACK REFERENCE GUIDE -C***END PROLOGUE DFCTRW - -C...SCALAR ARGUMENTS - INTEGER - + INFO,LDWD,LDWE,LD2WD,LD2WE, - + M,N,NNZW,NPP,NQ - LOGICAL - + ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M), - + WRK0(NQ,NQ),WRK4(M,M) - -C...LOCAL SCALARS - DOUBLE PRECISION - + ZERO - INTEGER - + I,INF,J,J1,J2,L,L1,L2 - LOGICAL - + NOTZRO - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DFCTR - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN INDEXING VARIABLE. -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C J: AN INDEXING VARIABLE. -C J1: AN INDEXING VARIABLE. -C J2: AN INDEXING VARIABLE. -C L: AN INDEXING VARIABLE. -C L1: AN INDEXING VARIABLE. -C L2: AN INDEXING VARIABLE. -C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. -C NOTZRO: THE VARIABLE DESIGNATING WHETHER A GIVEN COMPONENT OF THE -C WEIGHT ARRAY WE CONTAINS A NONZERO ELEMENT (NOTZRO=FALSE) -C OR NOT (NOTZRO=TRUE). -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. -C WE: THE (SQUARED) EPSILON WEIGHTS. -C WE1: THE FACTORED EPSILON WEIGHTS, S.T. TRANS(WE1)*WE1 = WE. -C WD: THE (SQUARED) DELTA WEIGHTS. -C WRK0: A WORK ARRAY OF (NQ BY NQ) ELEMENTS. -C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DFCTRW - - -C CHECK EPSILON WEIGHTS, AND STORE FACTORIZATION IN WE1 - - IF (WE(1,1,1).LT.ZERO) THEN -C WE CONTAINS A SCALAR - WE1(1,1,1) = -SQRT(ABS(WE(1,1,1))) - NNZW = N - - ELSE - NNZW = 0 - - IF (LDWE.EQ.1) THEN - - IF (LD2WE.EQ.1) THEN -C WE CONTAINS A DIAGONAL MATRIX - DO 110 L=1,NQ - IF (WE(1,1,L).GT.ZERO) THEN - NNZW = N - WE1(1,1,L) = SQRT(WE(1,1,L)) - ELSE IF (WE(1,1,L).LT.ZERO) THEN - INFO = 30010 - GO TO 300 - END IF - 110 CONTINUE - ELSE - -C WE CONTAINS A FULL NQ BY NQ SEMIDEFINITE MATRIX - DO 130 L1=1,NQ - DO 120 L2=L1,NQ - WRK0(L1,L2) = WE(1,L1,L2) - 120 CONTINUE - 130 CONTINUE - CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) - IF (INF.NE.0) THEN - INFO = 30010 - GO TO 300 - ELSE - DO 150 L1=1,NQ - DO 140 L2=1,NQ - WE1(1,L1,L2) = WRK0(L1,L2) - 140 CONTINUE - IF (WE1(1,L1,L1).NE.ZERO) THEN - NNZW = N - END IF - 150 CONTINUE - END IF - END IF - - ELSE - - IF (LD2WE.EQ.1) THEN -C WE CONTAINS AN ARRAY OF DIAGONAL MATRIX - DO 220 I=1,N - NOTZRO = .FALSE. - DO 210 L=1,NQ - IF (WE(I,1,L).GT.ZERO) THEN - NOTZRO = .TRUE. - WE1(I,1,L) = SQRT(WE(I,1,L)) - ELSE IF (WE(I,1,L).LT.ZERO) THEN - INFO = 30010 - GO TO 300 - END IF - 210 CONTINUE - IF (NOTZRO) THEN - NNZW = NNZW + 1 - END IF - 220 CONTINUE - ELSE - -C WE CONTAINS AN ARRAY OF FULL NQ BY NQ SEMIDEFINITE MATRICES - DO 270 I=1,N - DO 240 L1=1,NQ - DO 230 L2=L1,NQ - WRK0(L1,L2) = WE(I,L1,L2) - 230 CONTINUE - 240 CONTINUE - CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) - IF (INF.NE.0) THEN - INFO = 30010 - GO TO 300 - ELSE - NOTZRO = .FALSE. - DO 260 L1=1,NQ - DO 250 L2=1,NQ - WE1(I,L1,L2) = WRK0(L1,L2) - 250 CONTINUE - IF (WE1(I,L1,L1).NE.ZERO) THEN - NOTZRO = .TRUE. - END IF - 260 CONTINUE - END IF - IF (NOTZRO) THEN - NNZW = NNZW + 1 - END IF - 270 CONTINUE - END IF - END IF - END IF - -C CHECK FOR A SUFFICIENT NUMBER OF NONZERO EPSILON WEIGHTS - - IF (NNZW.LT.NPP) THEN - INFO = 30020 - END IF - - -C CHECK DELTA WEIGHTS - - 300 CONTINUE - IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN -C PROBLEM IS NOT ODR, OR WD CONTAINS A SCALAR - RETURN - - ELSE - - IF (LDWD.EQ.1) THEN - - IF (LD2WD.EQ.1) THEN -C WD CONTAINS A DIAGONAL MATRIX - DO 310 J=1,M - IF (WD(1,1,J).LE.ZERO) THEN - INFO = MAX(30001,INFO+1) - RETURN - END IF - 310 CONTINUE - ELSE - -C WD CONTAINS A FULL M BY M POSITIVE DEFINITE MATRIX - DO 330 J1=1,M - DO 320 J2=J1,M - WRK4(J1,J2) = WD(1,J1,J2) - 320 CONTINUE - 330 CONTINUE - CALL DFCTR(.FALSE.,WRK4,M,M,INF) - IF (INF.NE.0) THEN - INFO = MAX(30001,INFO+1) - RETURN - END IF - END IF - - ELSE - - IF (LD2WD.EQ.1) THEN -C WD CONTAINS AN ARRAY OF DIAGONAL MATRICES - DO 420 I=1,N - DO 410 J=1,M - IF (WD(I,1,J).LE.ZERO) THEN - INFO = MAX(30001,INFO+1) - RETURN - END IF - 410 CONTINUE - 420 CONTINUE - ELSE - -C WD CONTAINS AN ARRAY OF FULL M BY M POSITIVE DEFINITE MATRICES - DO 470 I=1,N - DO 440 J1=1,M - DO 430 J2=J1,M - WRK4(J1,J2) = WD(I,J1,J2) - 430 CONTINUE - 440 CONTINUE - CALL DFCTR(.FALSE.,WRK4,M,M,INF) - IF (INF.NE.0) THEN - INFO = MAX(30001,INFO+1) - RETURN - END IF - 470 CONTINUE - END IF - END IF - END IF - - RETURN - END -*DFLAGS - SUBROUTINE DFLAGS - + (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) -C***BEGIN PROLOGUE DFLAGS -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB -C***END PROLOGUE DFLAGS - -C...SCALAR ARGUMENTS - INTEGER - + JOB - LOGICAL - + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT - -C...LOCAL SCALARS - INTEGER - + J - -C...INTRINSIC FUNCTIONS - INTRINSIC - + MOD - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED -C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). -C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED -C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD -C DIFFERENCES (CDJAC=FALSE). -C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED -C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT -C (CHKJAC=FALSE). -C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS -C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED -C TO ZERO (INITD=TRUE) OR TO THE FIRST N BY M ELEMENTS OF -C ARRAY WORK (INITD=FALSE). -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C J: THE VALUE OF A SPECIFIC DIGIT OF JOB. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO -C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX -C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). -C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART -C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). - - -C***FIRST EXECUTABLE STATEMENT DFLAGS - - - IF (JOB.GE.0) THEN - - RESTRT= JOB.GE.10000 - - INITD = MOD(JOB,10000)/1000.EQ.0 - - J = MOD(JOB,1000)/100 - IF (J.EQ.0) THEN - DOVCV = .TRUE. - REDOJ = .TRUE. - ELSE IF (J.EQ.1) THEN - DOVCV = .TRUE. - REDOJ = .FALSE. - ELSE - DOVCV = .FALSE. - REDOJ = .FALSE. - END IF - - J = MOD(JOB,100)/10 - IF (J.EQ.0) THEN - ANAJAC = .FALSE. - CDJAC = .FALSE. - CHKJAC = .FALSE. - ELSE IF (J.EQ.1) THEN - ANAJAC = .FALSE. - CDJAC = .TRUE. - CHKJAC = .FALSE. - ELSE IF (J.EQ.2) THEN - ANAJAC = .TRUE. - CDJAC = .FALSE. - CHKJAC = .TRUE. - ELSE - ANAJAC = .TRUE. - CDJAC = .FALSE. - CHKJAC = .FALSE. - END IF - - J = MOD(JOB,10) - IF (J.EQ.0) THEN - ISODR = .TRUE. - IMPLCT = .FALSE. - ELSE IF (J.EQ.1) THEN - ISODR = .TRUE. - IMPLCT = .TRUE. - ELSE - ISODR = .FALSE. - IMPLCT = .FALSE. - END IF - - ELSE - - RESTRT = .FALSE. - INITD = .TRUE. - DOVCV = .TRUE. - REDOJ = .TRUE. - ANAJAC = .FALSE. - CDJAC = .FALSE. - CHKJAC = .FALSE. - ISODR = .TRUE. - IMPLCT = .FALSE. - - END IF - - RETURN - END -*DHSTEP - DOUBLE PRECISION FUNCTION DHSTEP - + (ITYPE,NETA,I,J,STP,LDSTP) -C***BEGIN PROLOGUE DHSTEP -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SET RELATIVE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES -C***END PROLOGUE DHSTEP - -C...SCALAR ARGUMENTS - INTEGER - + I,ITYPE,J,LDSTP,NETA - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + STP(LDSTP,J) - -C...LOCAL SCALARS - DOUBLE PRECISION - + TEN,THREE,TWO,ZERO - -C...DATA STATEMENTS - DATA - + ZERO,TWO,THREE,TEN - + /0.0D0,2.0D0,3.0D0,10.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. -C ITYPE: THE FINITE DIFFERENCE METHOD BEING USED, WHERE -C ITYPE = 0 INDICATES FORWARD FINITE DIFFERENCES, AND -C ITYPE = 1 INDICATES CENTRAL FINITE DIFFERENCES. -C J: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. -C LDSTP: THE LEADING DIMENSION OF ARRAY STP. -C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. -C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. -C TEN: THE VALUE 10.0D0. -C THREE: THE VALUE 3.0D0. -C TWO: THE VALUE 2.0D0. -C ZERO: THE VALUE 0.0D0. - - - -C***FIRST EXECUTABLE STATEMENT DHSTEP - - -C SET DHSTEP TO RELATIVE FINITE DIFFERENCE STEP SIZE - - IF (STP(1,1).LE.ZERO) THEN - - IF (ITYPE.EQ.0) THEN -C USE DEFAULT FORWARD FINITE DIFFERENCE STEP SIZE - DHSTEP = TEN**(-ABS(NETA)/TWO - TWO) - - ELSE -C USE DEFAULT CENTRAL FINITE DIFFERENCE STEP SIZE - DHSTEP = TEN**(-ABS(NETA)/THREE) - END IF - - ELSE IF (LDSTP.EQ.1) THEN - DHSTEP = STP(1,J) - - ELSE - DHSTEP = STP(I,J) - END IF - - RETURN - END -*DIFIX - SUBROUTINE DIFIX - + (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX) -C***BEGIN PROLOGUE DIFIX -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 910612 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SET ELEMENTS OF T TO ZERO ACCORDING TO IFIX -C***END PROLOGUE DIFIX - -C...SCALAR ARGUMENTS - INTEGER - + LDIFIX,LDT,LDTFIX,M,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + T(LDT,M),TFIX(LDTFIX,M) - INTEGER - + IFIX(LDIFIX,M) - -C...LOCAL SCALARS - DOUBLE PRECISION - + ZERO - INTEGER - + I,J - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN INDEXING VARIABLE. -C IFIX: THE ARRAY DESIGNATING WHETHER AN ELEMENT OF T IS TO BE -C SET TO ZERO. -C J: AN INDEXING VARIABLE. -C LDT: THE LEADING DIMENSION OF ARRAY T. -C LDIFIX: THE LEADING DIMENSION OF ARRAY IFIX. -C LDTFIX: THE LEADING DIMENSION OF ARRAY TFIX. -C M: THE NUMBER OF COLUMNS OF DATA IN THE ARRAY. -C N: THE NUMBER OF ROWS OF DATA IN THE ARRAY. -C T: THE ARRAY BEING SET TO ZERO ACCORDING TO THE ELEMENTS -C OF IFIX. -C TFIX: THE RESULTING ARRAY. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DIFIX - - - IF (N.EQ.0 .OR. M.EQ.0) RETURN - - IF (IFIX(1,1).GE.ZERO) THEN - IF (LDIFIX.GE.N) THEN - DO 20 J=1,M - DO 10 I=1,N - IF (IFIX(I,J).EQ.0) THEN - TFIX(I,J) = ZERO - ELSE - TFIX(I,J) = T(I,J) - END IF - 10 CONTINUE - 20 CONTINUE - ELSE - DO 100 J=1,M - IF (IFIX(1,J).EQ.0) THEN - DO 30 I=1,N - TFIX(I,J) = ZERO - 30 CONTINUE - ELSE - DO 90 I=1,N - TFIX(I,J) = T(I,J) - 90 CONTINUE - END IF - 100 CONTINUE - END IF - END IF - - RETURN - END -*DINIWK - SUBROUTINE DINIWK - + (N,M,NP,WORK,LWORK,IWORK,LIWORK, - + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, - + BETA,SCLB, - + SSTOL,PARTOL,MAXIT,TAUFAC, - + JOB,IPRINT,LUNERR,LUNRPT, - + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, - + JOBI,IPRINI,LUNERI,LUNRPI, - + SSFI,TTI,LDTTI,DELTAI) -C***BEGIN PROLOGUE DINIWK -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DFLAGS,DMPREC,DSCLB,DSCLD,DZERO -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE INITIALIZE WORK VECTORS AS NECESSARY -C***END PROLOGUE DINIWK - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + PARTOL,SSTOL,TAUFAC - INTEGER - + DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, - + LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M, - + MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M) - INTEGER - + IFIXX(LDIFX,M),IWORK(LIWORK) - -C...LOCAL SCALARS - DOUBLE PRECISION - + ONE,THREE,TWO,ZERO - INTEGER - + I,J - LOGICAL - + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DMPREC - EXTERNAL - + DMPREC - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DCOPY,DFLAGS,DSCLB,DSCLD,DZERO - -C...INTRINSIC FUNCTIONS - INTRINSIC - + MIN,SQRT - -C...DATA STATEMENTS - DATA - + ZERO,ONE,TWO,THREE - + /0.0D0,1.0D0,2.0D0,3.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE -C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT -C (ANAJAC=TRUE). -C BETA: THE FUNCTION PARAMETERS. -C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE -C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD -C DIFFERENCES (CDJAC=FALSE). -C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED -C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT -C (CHKJAC=FALSE). -C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. -C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS -C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). -C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. -C I: AN INDEXING VARIABLE. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED -C AT THEIR INPUT VALUES OR NOT. -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED -C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M -C ELEMENTS OF ARRAY WORK (INITD=FALSE). -C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. -C IPRINT: THE PRINT CONTROL VARIABLE. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C IWORK: THE INTEGER WORK SPACE. -C J: AN INDEXING VARIABLE. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. -C LDTTI: THE LEADING DIMENSION OF ARRAY TT. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LIWORK: THE LENGTH OF VECTOR IWORK. -C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. -C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. -C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. -C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C LWORK: THE LENGTH OF VECTOR WORK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. -C N: THE NUMBER OF OBSERVATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C ONE: THE VALUE 1.0D0. -C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. -C PARTOL: THE PARAMETER CONVERGENCE STOPPING CRITERIA. -C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO -C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX -C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). -C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART -C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). -C SCLB: THE SCALING VALUES FOR BETA. -C SCLD: THE SCALING VALUES FOR DELTA. -C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. -C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. -C THREE: THE VALUE 3.0D0. -C TTI: THE STARTING LOCATION IN ARRAY WORK OF THE ARRAY TT. -C TWO: THE VALUE 2.0D0. -C WORK: THE DOUBLE PRECISION WORK SPACE. -C X: THE INDEPENDENT VARIABLE. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DINIWK - - - CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, - + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) - -C STORE VALUE OF MACHINE PRECISION IN WORK VECTOR - - WORK(EPSMAI) = DMPREC() - -C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE -C PARAMETERS (SEE ALSO SUBPROGRAM DODCNT) - - IF (PARTOL.LT.ZERO) THEN - WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) - ELSE - WORK(PARTLI) = MIN(PARTOL, ONE) - END IF - -C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE -C SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS - - IF (SSTOL.LT.ZERO) THEN - WORK(SSTOLI) = SQRT(WORK(EPSMAI)) - ELSE - WORK(SSTOLI) = MIN(SSTOL, ONE) - END IF - -C SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION - - IF (TAUFAC.LE.ZERO) THEN - WORK(TAUFCI) = ONE - ELSE - WORK(TAUFCI) = MIN(TAUFAC, ONE) - END IF - -C SET MAXIMUM NUMBER OF ITERATIONS - - IF (MAXIT.LT.0) THEN - IWORK(MAXITI) = 50 - ELSE - IWORK(MAXITI) = MAXIT - END IF - -C STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL -C VARIABLE - - IF (JOB.LE.0) THEN - IWORK(JOBI) = 0 - ELSE - IWORK(JOBI) = JOB - END IF - -C SET PRINT CONTROL - - IF (IPRINT.LT.0) THEN - IWORK(IPRINI) = 2001 - ELSE - IWORK(IPRINI) = IPRINT - END IF - -C SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES - - IF (LUNERR.LT.0) THEN - IWORK(LUNERI) = 6 - ELSE - IWORK(LUNERI) = LUNERR - END IF - -C SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS - - IF (LUNRPT.LT.0) THEN - IWORK(LUNRPI) = 6 - ELSE - IWORK(LUNRPI) = LUNRPT - END IF - -C COMPUTE SCALING FOR BETA'S AND DELTA'S - - IF (SCLB(1).LE.ZERO) THEN - CALL DSCLB(NP,BETA,WORK(SSFI)) - ELSE - CALL DCOPY(NP,SCLB,1,WORK(SSFI),1) - END IF - IF (ISODR) THEN - IF (SCLD(1,1).LE.ZERO) THEN - IWORK(LDTTI) = N - CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) - ELSE - IF (LDSCLD.EQ.1) THEN - IWORK(LDTTI) = 1 - CALL DCOPY(M,SCLD(1,1),1,WORK(TTI),1) - ELSE - IWORK(LDTTI) = N - DO 10 J=1,M - CALL DCOPY(N,SCLD(1,J),1, - + WORK(TTI+(J-1)*IWORK(LDTTI)),1) - 10 CONTINUE - END IF - END IF - END IF - -C INITIALIZE DELTA'S AS NECESSARY - - IF (ISODR) THEN - IF (INITD) THEN - CALL DZERO(N,M,WORK(DELTAI),N) - ELSE - IF (IFIXX(1,1).GE.0) THEN - IF (LDIFX.EQ.1) THEN - DO 20 J=1,M - IF (IFIXX(1,J).EQ.0) THEN - CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N) - END IF - 20 CONTINUE - ELSE - DO 40 J=1,M - DO 30 I=1,N - IF (IFIXX(I,J).EQ.0) THEN - WORK(DELTAI-1+I+(J-1)*N) = ZERO - END IF - 30 CONTINUE - 40 CONTINUE - END IF - END IF - END IF - ELSE - CALL DZERO(N,M,WORK(DELTAI),N) - END IF - - RETURN - END -*DIWINF - SUBROUTINE DIWINF - + (M,NP,NQ, - + MSGBI,MSGDI,IFIX2I,ISTOPI, - + NNZWI,NPPI,IDFI, - + JOBI,IPRINI,LUNERI,LUNRPI, - + NROWI,NTOLI,NETAI, - + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, - + LIWKMN) -C***BEGIN PROLOGUE DIWINF -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE -C***END PROLOGUE DIWINF - -C...SCALAR ARGUMENTS - INTEGER - + IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI,LIWKMN, - + LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI,NJEVI, - + NNZWI,NP,NPPI,NQ,NROWI,NTOLI - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. -C IFIX2I: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY IFIX2. -C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. -C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. -C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. -C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. -C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. -C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. -C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. -C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. -C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. -C MSGBI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. -C MSGDI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. -C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. -C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. -C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABEL NITER. -C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. -C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. -C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. - - -C***FIRST EXECUTABLE STATEMENT DIWINF - - - IF (NP.GE.1 .AND. M.GE.1) THEN - MSGBI = 1 - MSGDI = MSGBI + NQ*NP+1 - IFIX2I = MSGDI + NQ*M+1 - ISTOPI = IFIX2I + NP - NNZWI = ISTOPI + 1 - NPPI = NNZWI + 1 - IDFI = NPPI + 1 - JOBI = IDFI + 1 - IPRINI = JOBI + 1 - LUNERI = IPRINI + 1 - LUNRPI = LUNERI + 1 - NROWI = LUNRPI + 1 - NTOLI = NROWI + 1 - NETAI = NTOLI + 1 - MAXITI = NETAI + 1 - NITERI = MAXITI + 1 - NFEVI = NITERI + 1 - NJEVI = NFEVI + 1 - INT2I = NJEVI + 1 - IRANKI = INT2I + 1 - LDTTI = IRANKI + 1 - LIWKMN = LDTTI - ELSE - MSGBI = 1 - MSGDI = 1 - IFIX2I = 1 - ISTOPI = 1 - NNZWI = 1 - NPPI = 1 - IDFI = 1 - JOBI = 1 - IPRINI = 1 - LUNERI = 1 - LUNRPI = 1 - NROWI = 1 - NTOLI = 1 - NETAI = 1 - MAXITI = 1 - NITERI = 1 - NFEVI = 1 - NJEVI = 1 - INT2I = 1 - IRANKI = 1 - LDTTI = 1 - LIWKMN = 1 - END IF - - RETURN - END -*DJACCD - SUBROUTINE DJACCD - + (FCN, - + N,M,NP,NQ, - + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, - + STPB,STPD,LDSTPD, - + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, - + FJACB,ISODR,FJACD,NFEV,ISTOP) -C***BEGIN PROLOGUE DJACCD -C***REFER TO DODR,DODRC -C***ROUTINES CALLED FCN,DHSTEP,DZERO -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE COMPUTE CENTRAL DIFFERENCE APPROXIMATIONS TO THE -C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS -C***END PROLOGUE DJACCD - -C...SCALAR ARGUMENTS - INTEGER - + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ - LOGICAL - + ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), - + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), - + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), - + X(LDX,M),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + BETAK,ONE,TYPJ,ZERO - INTEGER - + I,J,K,L - LOGICAL - + DOIT,SETZRO - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DZERO - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DHSTEP - EXTERNAL - + DHSTEP - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,MAX,SIGN,SQRT - -C...DATA STATEMENTS - DATA - + ZERO,ONE - + /0.0D0,1.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C BETAK: THE K-TH FUNCTION PARAMETER. -C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A GIVEN -C BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT -C (DOIT=FALSE). -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C I: AN INDEXING VARIABLE. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED -C AT THEIR INPUT VALUES OR NOT. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C J: AN INDEXING VARIABLE. -C K: AN INDEXING VARIABLE. -C L: AN INDEXING VARIABLE. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C ONE: THE VALUE 1.0D0. -C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME -C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT -C (SETZRO=FALSE). -C SSF: THE SCALING VALUES USED FOR BETA. -C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO EACH DELTA. -C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO EACH BETA. -C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO EACH DELTA. -C TT: THE SCALING VALUES USED FOR DELTA. -C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. -C X: THE EXPLANATORY VARIABLE. -C XPLUSD: THE VALUES OF X + DELTA. -C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK3: A WORK ARRAY OF (NP) ELEMENTS. -C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DJACCD - - -C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS - - DO 60 K=1,NP - IF (IFIXB(1).GE.0) THEN - IF (IFIXB(K).EQ.0) THEN - DOIT = .FALSE. - ELSE - DOIT = .TRUE. - END IF - ELSE - DOIT = .TRUE. - END IF - IF (.NOT.DOIT) THEN - DO 10 L=1,NQ - CALL DZERO(N,1,FJACB(1,K,L),N) - 10 CONTINUE - ELSE - BETAK = BETA(K) - IF (BETAK.EQ.ZERO) THEN - IF (SSF(1).LT.ZERO) THEN - TYPJ = ONE/ABS(SSF(1)) - ELSE - TYPJ = ONE/SSF(K) - END IF - ELSE - TYPJ = ABS(BETAK) - END IF - WRK3(K) = BETAK - + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(1,NETA,1,K,STPB,1) - WRK3(K) = WRK3(K) - BETAK - - BETA(K) = BETAK + WRK3(K) - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 001,WRK2,WRK6,WRK1, - + ISTOP) - IF (ISTOP.NE.0) THEN - RETURN - ELSE - NFEV = NFEV + 1 - DO 30 L=1,NQ - DO 20 I=1,N - FJACB(I,K,L) = WRK2(I,L) - 20 CONTINUE - 30 CONTINUE - END IF - - BETA(K) = BETAK - WRK3(K) - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 001,WRK2,WRK6,WRK1, - + ISTOP) - IF (ISTOP.NE.0) THEN - RETURN - ELSE - NFEV = NFEV + 1 - END IF - - DO 50 L=1,NQ - DO 40 I=1,N - FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K)) - 40 CONTINUE - 50 CONTINUE - BETA(K) = BETAK - END IF - 60 CONTINUE - -C COMPUTE THE JACOBIAN WRT THE X'S - - IF (ISODR) THEN - DO 220 J=1,M - IF (IFIXX(1,1).LT.0) THEN - DOIT = .TRUE. - SETZRO = .FALSE. - ELSE IF (LDIFX.EQ.1) THEN - IF (IFIXX(1,J).EQ.0) THEN - DOIT = .FALSE. - ELSE - DOIT = .TRUE. - END IF - SETZRO = .FALSE. - ELSE - DOIT = .FALSE. - SETZRO = .FALSE. - DO 100 I=1,N - IF (IFIXX(I,J).NE.0) THEN - DOIT = .TRUE. - ELSE - SETZRO = .TRUE. - END IF - 100 CONTINUE - END IF - IF (.NOT.DOIT) THEN - DO 110 L=1,NQ - CALL DZERO(N,1,FJACD(1,J,L),N) - 110 CONTINUE - ELSE - DO 120 I=1,N - IF (XPLUSD(I,J).EQ.ZERO) THEN - IF (TT(1,1).LT.ZERO) THEN - TYPJ = ONE/ABS(TT(1,1)) - ELSE IF (LDTT.EQ.1) THEN - TYPJ = ONE/TT(1,J) - ELSE - TYPJ = ONE/TT(I,J) - END IF - ELSE - TYPJ = ABS(XPLUSD(I,J)) - END IF - STP(I) = XPLUSD(I,J) - + + SIGN(ONE,XPLUSD(I,J)) - + *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD) - STP(I) = STP(I) - XPLUSD(I,J) - XPLUSD(I,J) = XPLUSD(I,J) + STP(I) - 120 CONTINUE - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 001,WRK2,WRK6,WRK1, - + ISTOP) - IF (ISTOP.NE.0) THEN - RETURN - ELSE - NFEV = NFEV + 1 - DO 140 L=1,NQ - DO 130 I=1,N - FJACD(I,J,L) = WRK2(I,L) - 130 CONTINUE - 140 CONTINUE - END IF - - DO 150 I=1,N - XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I) - 150 CONTINUE - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 001,WRK2,WRK6,WRK1, - + ISTOP) - IF (ISTOP.NE.0) THEN - RETURN - ELSE - NFEV = NFEV + 1 - END IF - - IF (SETZRO) THEN - DO 180 I=1,N - IF (IFIXX(I,J).EQ.0) THEN - DO 160 L=1,NQ - FJACD(I,J,L) = ZERO - 160 CONTINUE - ELSE - DO 170 L=1,NQ - FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ - + (2*STP(I)) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE - DO 200 L=1,NQ - DO 190 I=1,N - FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ - + (2*STP(I)) - 190 CONTINUE - 200 CONTINUE - END IF - DO 210 I=1,N - XPLUSD(I,J) = X(I,J) + DELTA(I,J) - 210 CONTINUE - END IF - 220 CONTINUE - END IF - - RETURN - END -*DJACFD - SUBROUTINE DJACFD - + (FCN, - + N,M,NP,NQ, - + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, - + STPB,STPD,LDSTPD, - + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, - + FJACB,ISODR,FJACD,NFEV,ISTOP) -C***BEGIN PROLOGUE DJACFD -C***REFER TO DODR,DODRC -C***ROUTINES CALLED FCN,DHSTEP,DZERO -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE COMPUTE FORWARD DIFFERENCE APPROXIMATIONS TO THE -C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS -C***END PROLOGUE DJACFD - -C...SCALAR ARGUMENTS - INTEGER - + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ - LOGICAL - + ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ), - + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), - + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), - + X(LDX,M),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + BETAK,ONE,TYPJ,ZERO - INTEGER - + I,J,K,L - LOGICAL - + DOIT,SETZRO - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DZERO - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DHSTEP - EXTERNAL - + DHSTEP - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,MAX,SIGN,SQRT - -C...DATA STATEMENTS - DATA - + ZERO,ONE - + /0.0D0,1.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C BETAK: THE K-TH FUNCTION PARAMETER. -C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A -C GIVEN BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) -C OR NOT (DOIT=FALSE). -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. -C I: AN INDEXING VARIABLE. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C J: AN INDEXING VARIABLE. -C K: AN INDEXING VARIABLE. -C L: AN INDEXING VARIABLE. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C ONE: THE VALUE 1.0D0. -C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME -C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT -C (SETZRO=FALSE). -C SSF: THE SCALE USED FOR THE BETA'S. -C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO BETA. -C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C TT: THE SCALING VALUES USED FOR DELTA. -C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. -C X: THE EXPLANATORY VARIABLE. -C XPLUSD: THE VALUES OF X + DELTA. -C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK3: A WORK ARRAY OF (NP) ELEMENTS. -C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DJACFD - - -C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS - - DO 40 K=1,NP - IF (IFIXB(1).GE.0) THEN - IF (IFIXB(K).EQ.0) THEN - DOIT = .FALSE. - ELSE - DOIT = .TRUE. - END IF - ELSE - DOIT = .TRUE. - END IF - IF (.NOT.DOIT) THEN - DO 10 L=1,NQ - CALL DZERO(N,1,FJACB(1,K,L),N) - 10 CONTINUE - ELSE - BETAK = BETA(K) - IF (BETAK.EQ.ZERO) THEN - IF (SSF(1).LT.ZERO) THEN - TYPJ = ONE/ABS(SSF(1)) - ELSE - TYPJ = ONE/SSF(K) - END IF - ELSE - TYPJ = ABS(BETAK) - END IF - WRK3(K) = BETAK - + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(0,NETA,1,K,STPB,1) - WRK3(K) = WRK3(K) - BETAK - BETA(K) = BETAK + WRK3(K) - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 001,WRK2,WRK6,WRK1, - + ISTOP) - IF (ISTOP.NE.0) THEN - RETURN - ELSE - NFEV = NFEV + 1 - END IF - DO 30 L=1,NQ - DO 20 I=1,N - FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K) - 20 CONTINUE - 30 CONTINUE - BETA(K) = BETAK - END IF - 40 CONTINUE - -C COMPUTE THE JACOBIAN WRT THE X'S - - IF (ISODR) THEN - DO 220 J=1,M - IF (IFIXX(1,1).LT.0) THEN - DOIT = .TRUE. - SETZRO = .FALSE. - ELSE IF (LDIFX.EQ.1) THEN - IF (IFIXX(1,J).EQ.0) THEN - DOIT = .FALSE. - ELSE - DOIT = .TRUE. - END IF - SETZRO = .FALSE. - ELSE - DOIT = .FALSE. - SETZRO = .FALSE. - DO 100 I=1,N - IF (IFIXX(I,J).NE.0) THEN - DOIT = .TRUE. - ELSE - SETZRO = .TRUE. - END IF - 100 CONTINUE - END IF - IF (.NOT.DOIT) THEN - DO 110 L=1,NQ - CALL DZERO(N,1,FJACD(1,J,L),N) - 110 CONTINUE - ELSE - DO 120 I=1,N - IF (XPLUSD(I,J).EQ.ZERO) THEN - IF (TT(1,1).LT.ZERO) THEN - TYPJ = ONE/ABS(TT(1,1)) - ELSE IF (LDTT.EQ.1) THEN - TYPJ = ONE/TT(1,J) - ELSE - TYPJ = ONE/TT(I,J) - END IF - ELSE - TYPJ = ABS(XPLUSD(I,J)) - END IF - - STP(I) = XPLUSD(I,J) - + + SIGN(ONE,XPLUSD(I,J)) - + *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD) - STP(I) = STP(I) - XPLUSD(I,J) - XPLUSD(I,J) = XPLUSD(I,J) + STP(I) - 120 CONTINUE - - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 001,WRK2,WRK6,WRK1, - + ISTOP) - IF (ISTOP.NE.0) THEN - RETURN - ELSE - NFEV = NFEV + 1 - DO 140 L=1,NQ - DO 130 I=1,N - FJACD(I,J,L) = WRK2(I,L) - 130 CONTINUE - 140 CONTINUE - - END IF - - IF (SETZRO) THEN - DO 180 I=1,N - IF (IFIXX(I,J).EQ.0) THEN - DO 160 L=1,NQ - FJACD(I,J,L) = ZERO - 160 CONTINUE - ELSE - DO 170 L=1,NQ - FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE - DO 200 L=1,NQ - DO 190 I=1,N - FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) - 190 CONTINUE - 200 CONTINUE - END IF - DO 210 I=1,N - XPLUSD(I,J) = X(I,J) + DELTA(I,J) - 210 CONTINUE - END IF - 220 CONTINUE - END IF - - RETURN - END -*DJCK - SUBROUTINE DJCK - + (FCN, - + N,M,NP,NQ, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, - + SSF,TT,LDTT, - + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, - + PV0,FJACB,FJACD, - + MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV, - + WRK1,WRK2,WRK6) -C***BEGIN PROLOGUE DJCK -C***REFER TO DODR,DODRC -C***ROUTINES CALLED FCN,DHSTEP,DJCKM -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS -C (ADAPTED FROM STARPAC SUBROUTINE DCKCNT) -C***END PROLOGUE DJCK - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + EPSMAC,ETA - INTEGER - + ISTOP,LDIFX,LDSTPD,LDTT, - + M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL - LOGICAL - + ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ), - + PV0(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), - + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),MSGB(1+NQ*NP),MSGD(1+NQ*M) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO - INTEGER - + IDEVAL,J,LQ,MSGB1,MSGD1 - LOGICAL - + ISFIXD,ISWRTB - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DJCKM - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DHSTEP - EXTERNAL - + DHSTEP - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,INT,LOG10 - -C...DATA STATEMENTS - DATA - + ZERO,P5,ONE - + /0.0D0,0.5D0,1.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND -C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. -C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND -C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING -C CHECKED. -C EPSMAC: THE VALUE OF MACHINE PRECISION. -C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. -C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. -C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE -C PERFORMED BY USER SUPPLIED SUBROUTINE FCN. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ISFIXD: THE VARIABLE DESIGNATING WHETHER THE PARAMETER IS FIXED -C (ISFIXD=TRUE) OR NOT (ISFIXD=FALSE). -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). -C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA -C (ISWRTB=TRUE) OR DELTA (ISWRTB=FALSE) ARE BEING CHECKED. -C J: AN INDEX VARIABLE. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. -C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. -C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. -C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER -C SET BY THE USER OR COMPUTED BY DETAF. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH -C THE DERIVATIVE IS CHECKED. -C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE -C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. -C ONE: THE VALUE 1.0D0. -C P5: THE VALUE 0.5D0. -C PV: THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR -C ROW NROW IS STORED. -C PV0: THE PREDICTED VALUES USING THE CURRENT PARAMETER ESTIMATES. -C SSF: THE SCALING VALUES USED FOR BETA. -C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. -C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. -C TOL: THE AGREEMENT TOLERANCE. -C TT: THE SCALING VALUES USED FOR DELTA. -C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. -C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. -C XPLUSD: THE VALUES OF X + DELTA. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DJCK - - -C SET TOLERANCE FOR CHECKING DERIVATIVES - - TOL = ETA**(0.25D0) - NTOL = MAX(ONE,P5-LOG10(TOL)) - - -C COMPUTE USER SUPPLIED DERIVATIVE VALUES - - ISTOP = 0 - IF (ISODR) THEN - IDEVAL = 110 - ELSE - IDEVAL = 010 - END IF - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + IDEVAL,WRK2,FJACB,FJACD, - + ISTOP) - IF (ISTOP.NE.0) THEN - RETURN - ELSE - NJEV = NJEV + 1 - END IF - -C CHECK DERIVATIVES WRT BETA FOR EACH RESPONSE OF OBSERVATION NROW - - MSGB1 = 0 - MSGD1 = 0 - - DO 30 LQ=1,NQ - -C SET PREDICTED VALUE OF MODEL AT CURRENT PARAMETER ESTIMATES - PV = PV0(NROW,LQ) - - ISWRTB = .TRUE. - DO 10 J=1,NP - - IF (IFIXB(1).LT.0) THEN - ISFIXD = .FALSE. - ELSE IF (IFIXB(J).EQ.0) THEN - ISFIXD = .TRUE. - ELSE - ISFIXD = .FALSE. - END IF - - IF (ISFIXD) THEN - MSGB(1+LQ+(J-1)*NQ) = -1 - ELSE - IF (BETA(J).EQ.ZERO) THEN - IF (SSF(1).LT.ZERO) THEN - TYPJ = ONE/ABS(SSF(1)) - ELSE - TYPJ = ONE/SSF(J) - END IF - ELSE - TYPJ = ABS(BETA(J)) - END IF - - H0 = DHSTEP(0,NETA,1,J,STPB,1) - HC0 = H0 - -C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW - - CALL DJCKM(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, - + ISWRTB,PV,FJACB(NROW,J,LQ), - + DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV, - + WRK1,WRK2,WRK6) - IF (ISTOP.NE.0) THEN - MSGB(1) = -1 - RETURN - ELSE - DIFF(LQ,J) = DIFFJ - END IF - END IF - - 10 CONTINUE - -C CHECK DERIVATIVES WRT X FOR EACH RESPONSE OF OBSERVATION NROW - - IF (ISODR) THEN - ISWRTB = .FALSE. - DO 20 J=1,M - - IF (IFIXX(1,1).LT.0) THEN - ISFIXD = .FALSE. - ELSE IF (LDIFX.EQ.1) THEN - IF (IFIXX(1,J).EQ.0) THEN - ISFIXD = .TRUE. - ELSE - ISFIXD = .FALSE. - END IF - ELSE - ISFIXD = .FALSE. - END IF - - IF (ISFIXD) THEN - MSGD(1+LQ+(J-1)*NQ) = -1 - ELSE - - IF (XPLUSD(NROW,J).EQ.ZERO) THEN - IF (TT(1,1).LT.ZERO) THEN - TYPJ = ONE/ABS(TT(1,1)) - ELSE IF (LDTT.EQ.1) THEN - TYPJ = ONE/TT(1,J) - ELSE - TYPJ = ONE/TT(NROW,J) - END IF - ELSE - TYPJ = ABS(XPLUSD(NROW,J)) - END IF - - H0 = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD) - HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD) - -C CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW - - CALL DJCKM(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, - + ISWRTB,PV,FJACD(NROW,J,LQ), - + DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV, - + WRK1,WRK2,WRK6) - IF (ISTOP.NE.0) THEN - MSGD(1) = -1 - RETURN - ELSE - DIFF(LQ,NP+J) = DIFFJ - END IF - END IF - - 20 CONTINUE - END IF - 30 CONTINUE - MSGB(1) = MSGB1 - MSGD(1) = MSGD1 - - RETURN - END -*DJCKC - SUBROUTINE DJCKC - + (FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, - + FD,TYPJ,PVPSTP,STP0, - + PV,D, - + DIFFJ,MSG,ISTOP,NFEV, - + WRK1,WRK2,WRK6) -C***BEGIN PROLOGUE DJCKC -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DJCKF,DPVB,DPVD -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE -C DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES -C (ADAPTED FROM STARPAC SUBROUTINE DCKCRV) -C***END PROLOGUE DJCKC - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ - INTEGER - + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW - LOGICAL - + ISWRTB - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DJCKF,DPVB,DPVD - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,SIGN - -C...DATA STATEMENTS - DATA - + P01,ONE,TWO,TEN - + /0.01D0,1.0D0,2.0D0,10.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. -C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. -C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND -C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING -C CHECKED. -C EPSMAC: THE VALUE OF MACHINE PRECISION. -C ETA: THE RELATIVE NOISE IN THE MODEL -C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. -C HC: THE RELATIVE STEP SIZE FOR CENTRAL FINITE DIFFERENCES. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA -C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. -C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MSG: THE ERROR CHECKING RESULTS. -C N: THE NUMBER OF OBSERVATIONS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH -C THE DERIVATIVE IS TO BE CHECKED. -C ONE: THE VALUE 1.0D0. -C PV: THE PREDICTED VALUE OF THE MODEL FOR ROW NROW . -C PVMCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL -C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE -C JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV. -C PVPCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL -C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE -C JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV. -C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL -C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE -C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. -C P01: THE VALUE 0.01D0. -C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. -C STP: A STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. -C STPCRV: THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. -C TEN: THE VALUE 10.0D0. -C TOL: THE AGREEMENT TOLERANCE. -C TWO: THE VALUE 2.0D0. -C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. -C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. -C XPLUSD: THE VALUES OF X + DELTA. - - -C***FIRST EXECUTABLE STATEMENT DJCKC - - - IF (ISWRTB) THEN - -C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA - - STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) - CALL DPVB(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STPCRV, - + ISTOP,NFEV,PVPCRV, - + WRK1,WRK2,WRK6) - IF (ISTOP.NE.0) THEN - RETURN - END IF - CALL DPVB(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,-STPCRV, - + ISTOP,NFEV,PVMCRV, - + WRK1,WRK2,WRK6) - IF (ISTOP.NE.0) THEN - RETURN - END IF - ELSE - -C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT DELTA - - STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - - + XPLUSD(NROW,J) - CALL DPVD(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STPCRV, - + ISTOP,NFEV,PVPCRV, - + WRK1,WRK2,WRK6) - IF (ISTOP.NE.0) THEN - RETURN - END IF - CALL DPVD(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,-STPCRV, - + ISTOP,NFEV,PVMCRV, - + WRK1,WRK2,WRK6) - IF (ISTOP.NE.0) THEN - RETURN - END IF - END IF - -C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL - - CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) - CURVE = CURVE + - + ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2) - - -C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. - CALL DJCKF(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + ETA,TOL,NROW,J,LQ,ISWRTB, - + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, - + DIFFJ,MSG,ISTOP,NFEV, - + WRK1,WRK2,WRK6) - IF (ISTOP.NE.0) THEN - RETURN - END IF - IF (MSG(LQ,J).EQ.0) THEN - RETURN - END IF - -C CHECK IF HIGH CURVATURE COULD BE THE PROBLEM. - - STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC) - IF (STP.LT.ABS(TEN*STP0)) THEN - STP = MIN(STP,P01*ABS(STP0)) - END IF - - - IF (ISWRTB) THEN - -C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA - STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J) - CALL DPVB(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STP, - + ISTOP,NFEV,PVPSTP, - + WRK1,WRK2,WRK6) - IF (ISTOP.NE.0) THEN - RETURN - END IF - ELSE - -C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA - STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - - + XPLUSD(NROW,J) - CALL DPVD(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STP, - + ISTOP,NFEV,PVPSTP, - + WRK1,WRK2,WRK6) - IF (ISTOP.NE.0) THEN - RETURN - END IF - END IF - -C COMPUTE THE NEW NUMERICAL DERIVATIVE - - FD = (PVPSTP-PV)/STP - DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) - -C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK - IF (ABS(FD-D).LE.TOL*ABS(D)) THEN - MSG(LQ,J) = 0 - -C CHECK IF FINITE PRECISION MAY BE THE CULPRIT (FUDGE FACTOR = 2) - ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP)) - + + CURVE*(EPSMAC*TYPJ)**2) THEN - MSG(LQ,J) = 5 - END IF - - RETURN - END -*DJCKF - SUBROUTINE DJCKF - + (FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + ETA,TOL,NROW,J,LQ,ISWRTB, - + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, - + DIFFJ,MSG,ISTOP,NFEV, - + WRK1,WRK2,WRK6) -C***BEGIN PROLOGUE DJCKF -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DPVB,DPVD -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE -C CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES -C (ADAPTED FROM STARPAC SUBROUTINE DCKFPA) -C***END PROLOGUE DJCKF - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ - INTEGER - + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW - LOGICAL - + ISWRTB - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + HUNDRD,ONE,P1,STP,TWO - LOGICAL - + LARGE - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DPVB,DPVD - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,SIGN - -C...DATA STATEMENTS - DATA - + P1,ONE,TWO,HUNDRD - + /0.1D0,1.0D0,2.0D0,100.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. -C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. -C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND -C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING -C CHECKED. -C ETA: THE RELATIVE NOISE IN THE MODEL -C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. -C HUNDRD: THE VALUE 100.0D0. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA -C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. -C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. -C LARGE: THE VALUE DESIGNATING WHETHER THE RECOMMENDED INCREASE IN -C THE STEP SIZE WOULD BE GREATER THAN TYPJ. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MSG: THE ERROR CHECKING RESULTS. -C N: THE NUMBER OF OBSERVATIONS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH -C THE DERIVATIVE IS TO BE CHECKED. -C ONE: THE VALUE 1.0D0. -C PV: THE PREDICTED VALUE FOR ROW NROW . -C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL -C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE -C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. -C P1: THE VALUE 0.1D0. -C STP0: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. -C TOL: THE AGREEMENT TOLERANCE. -C TWO: THE VALUE 2.0D0. -C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. -C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. -C XPLUSD: THE VALUES OF X + DELTA. - - -C***FIRST EXECUTABLE STATEMENT DJCKF - - -C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. -C TRY A LARGER STEP SIZE BASED ON ESTIMATE OF CONDITION ERROR - - STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D)) - IF (STP.GT.ABS(P1*STP0)) THEN - STP = MAX(STP,HUNDRD*ABS(STP0)) - END IF - IF (STP.GT.TYPJ) THEN - STP = TYPJ - LARGE = .TRUE. - ELSE - LARGE = .FALSE. - END IF - - IF (ISWRTB) THEN - -C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA - STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) - CALL DPVB(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STP, - + ISTOP,NFEV,PVPSTP, - + WRK1,WRK2,WRK6) - ELSE - -C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA - STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - - + XPLUSD(NROW,J) - CALL DPVD(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STP, - + ISTOP,NFEV,PVPSTP, - + WRK1,WRK2,WRK6) - END IF - IF (ISTOP.NE.0) THEN - RETURN - END IF - - FD = (PVPSTP-PV)/STP - DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) - -C CHECK FOR AGREEMENT - - IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN -C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE. - MSG(LQ,J) = 0 - - ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN -C CURVATURE MAY BE THE CULPRIT (FUDGE FACTOR = 2) - IF (LARGE) THEN - MSG(LQ,J) = 4 - ELSE - MSG(LQ,J) = 5 - END IF - END IF - - RETURN - END -*DJCKM - SUBROUTINE DJCKM - + (FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, - + ISWRTB,PV,D, - + DIFFJ,MSG1,MSG,ISTOP,NFEV, - + WRK1,WRK2,WRK6) -C***BEGIN PROLOGUE DJCKM -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DJCKC,DJCKZ,DPVB,DPVD -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE CHECK USER SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL -C DERIVATIVES -C (ADAPTED FROM STARPAC SUBROUTINE DCKMN) -C***END PROLOGUE DJCKM - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ - INTEGER - + ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW - LOGICAL - + ISWRTB - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0, - + TEN,THREE,TOL2,TWO,ZERO - INTEGER - + I - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DJCKC,DJCKZ,DPVB,DPVD - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,MAX,SIGN,SQRT - -C...DATA STATEMENTS - DATA - + ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD - + /0.0D0,0.01D0,0.1D0,1.0D0,2.0D0,3.0D0,1.0D1,1.0D2/ - DATA - + BIG,TOL2 - + /1.0D19,5.0D-2/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C BIG: A BIG VALUE, USED TO INITIALIZE DIFFJ. -C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. -C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND -C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING -C CHECKED. -C EPSMAC: THE VALUE OF MACHINE PRECISION. -C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. -C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. -C H: THE RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. -C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. -C H1: THE DEFAULT RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. -C HC: THE RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. -C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. -C HC1: THE DEFAULT RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. -C HUNDRD: THE VALUE 100.0D0. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA -C (ISWRTB=TRUE) OR DELTAS (ISWRTB=FALSE) ARE BEING CHECKED. -C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MSG: THE ERROR CHECKING RESULTS. -C MSG1: THE ERROR CHECKING RESULTS SUMMARY. -C N: THE NUMBER OF OBSERVATIONS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH -C THE DERIVATIVE IS TO BE CHECKED. -C ONE: THE VALUE 1.0D0. -C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . -C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL -C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE JTH -C PARAMETER VALUE, WHICH IS BETA(J) + STP0. -C P01: THE VALUE 0.01D0. -C P1: THE VALUE 0.1D0. -C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. -C TEN: THE VALUE 10.0D0. -C THREE: THE VALUE 3.0D0. -C TWO: THE VALUE 2.0D0. -C TOL: THE AGREEMENT TOLERANCE. -C TOL2: A MINIMUM AGREEMENT TOLERANCE. -C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. -C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. -C XPLUSD: THE VALUES OF X + DELTA. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DJCKM - - -C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE -C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES - - H1 = SQRT(ETA) - HC1 = ETA**(ONE/THREE) - - MSG(LQ,J) = 7 - DIFFJ = BIG - - DO 10 I=1,3 - - IF (I.EQ.1) THEN -C TRY INITIAL RELATIVE STEP SIZE - H = H0 - HC = HC0 - - ELSE IF (I.EQ.2) THEN -C TRY LARGER RELATIVE STEP SIZE - H = MAX(TEN*H1, MIN(HUNDRD*H0, ONE)) - HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE)) - - ELSE IF (I.EQ.3) THEN -C TRY SMALLER RELATIVE STEP SIZE - H = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC)) - HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC)) - END IF - - IF (ISWRTB) THEN - -C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA - - STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) - CALL DPVB(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STP0, - + ISTOP,NFEV,PVPSTP, - + WRK1,WRK2,WRK6) - ELSE - -C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA - - STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - + - XPLUSD(NROW,J) - CALL DPVD(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STP0, - + ISTOP,NFEV,PVPSTP, - + WRK1,WRK2,WRK6) - END IF - IF (ISTOP.NE.0) THEN - RETURN - END IF - - FD = (PVPSTP-PV)/STP0 - -C CHECK FOR AGREEMENT - - IF (ABS(FD-D).LE.TOL*ABS(D)) THEN -C NUMERICAL AND ANALYTIC DERIVATIVES AGREE - -C SET RELATIVE DIFFERENCE FOR DERIVATIVE CHECKING REPORT - IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN - DIFFJ = ABS(FD-D) - ELSE - DIFFJ = ABS(FD-D)/ABS(D) - END IF - -C SET MSG FLAG. - IF (D.EQ.ZERO) THEN - -C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH ZERO. - MSG(LQ,J) = 1 - - ELSE -C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH NONZERO. - MSG(LQ,J) = 0 - END IF - - ELSE - -C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE. CHECK WHY - IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN - CALL DJCKZ(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,EPSMAC,J,LQ,ISWRTB, - + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, - + DIFFJ,MSG,ISTOP,NFEV, - + WRK1,WRK2,WRK6) - ELSE - CALL DJCKC(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, - + FD,TYPJ,PVPSTP,STP0,PV,D, - + DIFFJ,MSG,ISTOP,NFEV, - + WRK1,WRK2,WRK6) - END IF - IF (MSG(LQ,J).LE.2) THEN - GO TO 20 - END IF - END IF - 10 CONTINUE - -C SET SUMMARY FLAG TO INDICATE QUESTIONABLE RESULTS - 20 CONTINUE - IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6 - IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN - MSG1 = MAX(MSG1,1) - ELSE IF (MSG(LQ,J).GE.7) THEN - MSG1 = 2 - END IF - - RETURN - END -*DJCKZ - SUBROUTINE DJCKZ - + (FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,EPSMAC,J,LQ,ISWRTB, - + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, - + DIFFJ,MSG,ISTOP,NFEV, - + WRK1,WRK2,WRK6) -C***BEGIN PROLOGUE DJCKZ -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DPVB,DPVD -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE -C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC -C DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO -C (ADAPTED FROM STARPAC SUBROUTINE DCKZRO) -C***END PROLOGUE DJCKZ - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ - INTEGER - + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW - LOGICAL - + ISWRTB - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + CD,ONE,PVMSTP,THREE,TWO,ZERO - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DPVB,DPVD - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,MIN - -C...DATA STATEMENTS - DATA - + ZERO,ONE,TWO,THREE - + /0.0D0,1.0D0,2.0D0,3.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C CD: THE CENTRAL DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. -C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. -C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND -C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING -C CHECKED. -C EPSMAC: THE VALUE OF MACHINE PRECISION. -C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA -C (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED. -C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MSG: THE ERROR CHECKING RESULTS. -C N: THE NUMBER OF OBSERVATIONS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH -C THE DERIVATIVE IS TO BE CHECKED. -C ONE: THE VALUE 1.0D0. -C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . -C PVMSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL -C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE -C JTH PARAMETER VALUE, WHICH IS BETA(J) - STP0. -C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL -C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE -C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. -C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. -C THREE: THE VALUE 3.0D0. -C TWO: THE VALUE 2.0D0. -C TOL: THE AGREEMENT TOLERANCE. -C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. -C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. -C XPLUSD: THE VALUES OF X + DELTA. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DJCKZ - - -C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP -C SIZE OF 2*STP0 - - IF (ISWRTB) THEN - -C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA - - CALL DPVB(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,-STP0, - + ISTOP,NFEV,PVMSTP, - + WRK1,WRK2,WRK6) - ELSE - -C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA - - CALL DPVD(FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,-STP0, - + ISTOP,NFEV,PVMSTP, - + WRK1,WRK2,WRK6) - END IF - IF (ISTOP.NE.0) THEN - RETURN - END IF - - CD = (PVPSTP-PVMSTP)/(TWO*STP0) - DIFFJ = MIN(ABS(CD-D),ABS(FD-D)) - -C CHECK FOR AGREEMENT - - IF (DIFFJ.LE.TOL*ABS(D)) THEN - -C FINITE DIFFERENCE AND ANALYTIC DERIVATIVES NOW AGREE. - IF (D.EQ.ZERO) THEN - MSG(LQ,J) = 1 - ELSE - MSG(LQ,J) = 0 - END IF - - ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN -C DERIVATIVES ARE BOTH CLOSE TO ZERO - MSG(LQ,J) = 2 - - ELSE -C DERIVATIVES ARE NOT BOTH CLOSE TO ZERO - MSG(LQ,J) = 3 - END IF - - RETURN - END -*DODCHK - SUBROUTINE DODCHK - + (N,M,NP,NQ, - + ISODR,ANAJAC,IMPLCT, - + IFIXB, - + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, - + LDY, - + LWORK,LWKMN,LIWORK,LIWKMN, - + SCLB,SCLD,STPB,STPD, - + INFO) -C***BEGIN PROLOGUE DODCHK -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING -C NONZERO VALUES OF ARGUMENT INFO -C***END PROLOGUE DODCHK - -C...SCALAR ARGUMENTS - INTEGER - + INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, - + LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ - LOGICAL - + ANAJAC,IMPLCT,ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M) - INTEGER - + IFIXB(NP) - -C...LOCAL SCALARS - INTEGER - + I,J,K,LAST,NPP - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE -C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT -C (ANAJAC=TRUE). -C I: AN INDEXING VARIABLE. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C J: AN INDEXING VARIABLE. -C K: AN INDEXING VARIABLE. -C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDY: THE LEADING DIMENSION OF ARRAY X. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. -C LIWORK: THE LENGTH OF VECTOR IWORK. -C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. -C LWORK: THE LENGTH OF VECTOR WORK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. -C SCLB: THE SCALING VALUES FOR BETA. -C SCLD: THE SCALING VALUE FOR DELTA. -C STPB: THE STEP FOR THE FINITE DIFFERENCE DERIVATIVE WRT BETA. -C STPD: THE STEP FOR THE FINITE DIFFERENCE DERIVATIVE WRT DELTA. - - -C***FIRST EXECUTABLE STATEMENT DODCHK - - -C FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED - - IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN - NPP = NP - ELSE - NPP = 0 - DO 10 K=1,NP - IF (IFIXB(K).NE.0) THEN - NPP = NPP + 1 - END IF - 10 CONTINUE - END IF - -C CHECK PROBLEM SPECIFICATION PARAMETERS - - IF (N.LE.0 .OR. - + M.LE.0 .OR. - + (NPP.LE.0 .OR. NPP.GT.N) .OR. - + (NQ.LE.0)) THEN - - INFO = 10000 - IF (N.LE.0) THEN - INFO = INFO + 1000 - END IF - IF (M.LE.0) THEN - INFO = INFO + 100 - END IF - IF (NPP.LE.0 .OR. NPP.GT.N) THEN - INFO = INFO + 10 - END IF - IF (NQ.LE.0) THEN - INFO = INFO + 1 - END IF - - RETURN - - END IF - -C CHECK DIMENSION SPECIFICATION PARAMETERS - - IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR. - + (LDX.LT.N) .OR. - + (LDWE.NE.1 .AND. LDWE.LT.N) .OR. - + (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR. - + (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR. - + (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR. - + (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR. - + (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR. - + (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR. - + (LWORK.LT.LWKMN) .OR. - + (LIWORK.LT.LIWKMN)) THEN - - INFO = 20000 - IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN - INFO = INFO + 1000 - END IF - IF (LDX.LT.N) THEN - INFO = INFO + 2000 - END IF - - IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR. - + (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN - INFO = INFO + 100 - END IF - IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. - + (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN - INFO = INFO + 200 - END IF - - IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN - INFO = INFO + 10 - END IF - IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN - INFO = INFO + 20 - END IF - IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN - INFO = INFO + 40 - END IF - - IF (LWORK.LT.LWKMN) THEN - INFO = INFO + 1 - END IF - IF (LIWORK.LT.LIWKMN) THEN - INFO = INFO + 2 - END IF - RETURN - - END IF - -C CHECK DELTA SCALING - - IF (ISODR .AND. SCLD(1,1).GT.0) THEN - IF (LDSCLD.GE.N) THEN - LAST = N - ELSE - LAST = 1 - END IF - DO 120 J=1,M - DO 110 I=1,LAST - IF (SCLD(I,J).LE.0) THEN - INFO = 30200 - GO TO 130 - END IF - 110 CONTINUE - 120 CONTINUE - END IF - 130 CONTINUE - -C CHECK BETA SCALING - - IF (SCLB(1).GT.0) THEN - DO 210 K=1,NP - IF (SCLB(K).LE.0) THEN - IF (INFO.EQ.0) THEN - INFO = 30100 - ELSE - INFO = INFO + 100 - END IF - GO TO 220 - END IF - 210 CONTINUE - END IF - 220 CONTINUE - -C CHECK DELTA FINITE DIFFERENCE STEP SIZES - - IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN - IF (LDSTPD.GE.N) THEN - LAST = N - ELSE - LAST = 1 - END IF - DO 320 J=1,M - DO 310 I=1,LAST - IF (STPD(I,J).LE.0) THEN - IF (INFO.EQ.0) THEN - INFO = 32000 - ELSE - INFO = INFO + 2000 - END IF - GO TO 330 - END IF - 310 CONTINUE - 320 CONTINUE - END IF - 330 CONTINUE - -C CHECK BETA FINITE DIFFERENCE STEP SIZES - - IF (ANAJAC .AND. STPB(1).GT.0) THEN - DO 410 K=1,NP - IF (STPB(K).LE.0) THEN - IF (INFO.EQ.0) THEN - INFO = 31000 - ELSE - INFO = INFO + 1000 - END IF - GO TO 420 - END IF - 410 CONTINUE - END IF - 420 CONTINUE - - RETURN - END -*DODCNT - SUBROUTINE DODCNT - + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, - + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, IPRINT,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, - + WORK,LWORK,IWORK,LIWORK, - + INFO) -C***BEGIN PROLOGUE DODCNT -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DODDRV -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING -C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE -C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST -C SQUARES (OLS) SOLUTION -C***END PROLOGUE DODCNT - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + PARTOL,SSTOL,TAUFAC - INTEGER - + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, - + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ - LOGICAL - + SHORT - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), - + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), - + X(LDX,M),Y(LDY,NQ) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO - INTEGER - + IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5, - + MAXITI,MAXIT1 - LOGICAL - + DONE,FSTITR,HEAD,IMPLCT,PRTPEN - -C...LOCAL ARRAYS - DOUBLE PRECISION - + PNLTY(1,1,1) - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DODDRV - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DMPREC - EXTERNAL - + DMPREC - -C...DATA STATEMENTS - DATA - + PCHECK,PSTART,PFAC,ZERO,ONE,THREE - + /1.0D3,1.0D1,1.0D1,0.0D0,1.0D0,3.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C CNVTOL: THE CONVERGENCE TOLERANCE FOR IMPLICIT MODELS. -C DONE: THE VARIABLE DESIGNATING WHETHER THE INPLICIT SOLUTION HAS -C BEEN FOUND (DONE=TRUE) OR NOT (DONE=FALSE). -C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST -C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). -C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE -C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C IPRINT: THE PRINT CONTROL VARIABLES. -C IPRNTI: THE PRINT CONTROL VARIABLES. -C IPR1: THE 1ST DIGIT OF THE PRINT CONTROL VARIABLE. -C IPR2: THE 2ND DIGIT OF THE PRINT CONTROL VARIABLE. -C IPR3: THE 3RD DIGIT OF THE PRINT CONTROL VARIABLE. -C IPR4: THE 4TH DIGIT OF THE PRINT CONTROL VARIABLE. -C IWORK: THE INTEGER WORK SPACE. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C JOBI: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C JOB1: THE 1ST DIGIT OF THE VARIABLE CONTROLLING PROBLEM -C INITIALIZATION AND COMPUTATIONAL METHOD. -C JOB2: THE 2ND DIGIT OF THE VARIABLE CONTROLLING PROBLEM -C INITIALIZATION AND COMPUTATIONAL METHOD. -C JOB3: THE 3RD DIGIT OF THE VARIABLE CONTROLLING PROBLEM -C INITIALIZATION AND COMPUTATIONAL METHOD. -C JOB4: THE 4TH DIGIT OF THE VARIABLE CONTROLLING PROBLEM -C INITIALIZATION AND COMPUTATIONAL METHOD. -C JOB5: THE 5TH DIGIT OF THE VARIABLE CONTROLLING PROBLEM -C INITIALIZATION AND COMPUTATIONAL METHOD. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LIWORK: THE LENGTH OF VECTOR IWORK. -C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. -C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C LWORK: THE LENGTH OF VECTOR WORK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C MAXITI: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR -C THE CURRENT PENALTY PARAMETER VALUE. -C MAXIT1: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR -C THE NEXT PENALTY PARAMETER VALUE. -C N: THE NUMBER OF OBSERVATIONS. -C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS -C SUPPLIED BY THE USER. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C ONE: THE VALUE 1.0D0. -C PARTOL: THE USER SUPPLIED PARAMETER CONVERGENCE STOPPING TOLERANCE. -C PCHECK: THE VALUE DESIGNATING THE MINIMUM PENALTY PARAMETER ALLOWED -C BEFORE THE IMPLICIT PROBLEM CAN BE CONSIDERED SOLVED. -C PFAC: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. -C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. -C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO BE -C PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT -C (PRTPEN=FALSE). -C PSTART: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. -C SCLB: THE SCALING VALUES FOR BETA. -C SCLD: THE SCALING VALUES FOR DELTA. -C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO BETA. -C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED -C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL -C (SHORT=.FALSE.). -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C THREE: THE VALUE 3.0D0. -C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL -C VALUES AND THE SOLUTION. -C WD: THE DELTA WEIGHTS. -C WE: THE EPSILON WEIGHTS. -C WORK: THE DOUBLE PRECISION WORK SPACE. -C X: THE INDEPENDENT VARIABLE. -C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODCNT - - - IMPLCT = MOD(JOB,10).EQ.1 - FSTITR = .TRUE. - HEAD = .TRUE. - PRTPEN = .FALSE. - - IF (IMPLCT) THEN - -C SET UP FOR IMPLICIT PROBLEM - - IF (IPRINT.GE.0) THEN - IPR1 = MOD(IPRINT,10000)/1000 - IPR2 = MOD(IPRINT,1000)/100 - IPR2F = MOD(IPRINT,100)/10 - IPR3 = MOD(IPRINT,10) - ELSE - IPR1 = 2 - IPR2 = 0 - IPR2F = 0 - IPR3 = 1 - END IF - IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 - - JOB5 = MOD(JOB,100000)/10000 - JOB4 = MOD(JOB,10000)/1000 - JOB3 = MOD(JOB,1000)/100 - JOB2 = MOD(JOB,100)/10 - JOB1 = MOD(JOB,10) - JOBI = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1 - - IF (WE(1,1,1).LE.ZERO) THEN - PNLTY(1,1,1) = -PSTART - ELSE - PNLTY(1,1,1) = -WE(1,1,1) - END IF - - IF (PARTOL.LT.ZERO) THEN - CNVTOL = DMPREC()**(ONE/THREE) - ELSE - CNVTOL = MIN(PARTOL,ONE) - END IF - - IF (MAXIT.GE.1) THEN - MAXITI = MAXIT - ELSE - MAXITI = 100 - END IF - - DONE = MAXITI.EQ.0 - PRTPEN = .TRUE. - - 10 CONTINUE - CALL DODDRV - + (SHORT,HEAD,FSTITR,PRTPEN, - + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, - + PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, - + JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI, - + IPRNTI,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, - + WORK,LWORK,IWORK,LIWORK, - + MAXIT1,TSTIMP, INFO) - - IF (DONE) THEN - RETURN - ELSE - DONE = MAXIT1.LE.0 .OR. - + (ABS(PNLTY(1,1,1)).GE.PCHECK .AND. - + TSTIMP.LE.CNVTOL) - END IF - - IF (DONE) THEN - IF (TSTIMP.LE.CNVTOL) THEN - INFO = (INFO/10)*10 + 2 - ELSE - INFO = (INFO/10)*10 + 4 - END IF - JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1 - MAXITI = 0 - IPRNTI = IPR3 - ELSE - PRTPEN = .TRUE. - PNLTY(1,1,1) = PFAC*PNLTY(1,1,1) - JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1 - MAXITI = MAXIT1 - IPRNTI = 0000 + IPR2*100 + IPR2F*10 - END IF - GO TO 10 - ELSE - CALL DODDRV - + (SHORT,HEAD,FSTITR,PRTPEN, - + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, - + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, - + IPRINT,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, - + WORK,LWORK,IWORK,LIWORK, - + MAXIT1,TSTIMP, INFO) - END IF - - RETURN - - END -*DODDRV - SUBROUTINE DODDRV - + (SHORT,HEAD,FSTITR,PRTPEN, - + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, - + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, - + IPRINT,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, - + WORK,LWORK,IWORK,LIWORK, - + MAXIT1,TSTIMP, INFO) -C***BEGIN PROLOGUE DODDRV -C***REFER TO DODR,DODRC -C***ROUTINES CALLED FCN,DCOPY,DDOT,DETAF,DFCTRW,DFLAGS, -C DINIWK,DIWINF,DJCK,DNRM2,DODCHK,DODMN, -C DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN -C PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION -C (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) -C***END PROLOGUE DODDRV - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + PARTOL,SSTOL,TAUFAC,TSTIMP - INTEGER - + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, - + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1, - + N,NDIGIT,NP,NQ - LOGICAL - + FSTITR,HEAD,PRTPEN,SHORT - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), - + WE(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),WORK(LWORK), - + X(LDX,M),Y(LDY,NQ) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + EPSMAC,ETA,P5,ONE,TEN,ZERO - INTEGER - + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, - + DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I,IPRINI, - + IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN, - + LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI, - + NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI, - + NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, - + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, - + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK, - + WSSI,WSSDEI,WSSEPI,XPLUSI - LOGICAL - + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DDOT,DNRM2 - EXTERNAL - + DDOT,DNRM2 - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DCOPY,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK, - + DODMN,DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY - -C...DATA STATEMENTS - DATA - + ZERO,P5,ONE,TEN - + /0.0D0,0.5D0,1.0D0,10.0D0/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. -C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. -C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE -C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT -C (ANAJAC=TRUE). -C BETA: THE FUNCTION PARAMETERS. -C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. -C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. -C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. -C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. -C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE -C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD -C DIFFERENCES (CDJAC=FALSE). -C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED -C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT -C (CHKJAC=FALSE). -C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. -C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. -C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. -C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. -C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS -C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). -C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. -C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. -C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. -C FI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY F. -C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. -C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. -C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. -C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. -C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST -C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). -C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE -C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). -C I: AN INDEX VARIABLE. -C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED -C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M -C ELEMENTS OF ARRAY WORK (INITD=FALSE). -C INT2I: THE IN ARRAY IWORK OF VARIABLE INT2. -C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. -C IPRINT: THE PRINT CONTROL VARIABLE. -C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. -C IWORK: THE INTEGER WORK SPACE. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. -C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY JPVT. -C K: AN INDEX VARIABLE. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. -C LIWORK: THE LENGTH OF VECTOR IWORK. -C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. -C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. -C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. -C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. -C LWORK: THE LENGTH OF VECTOR WORK. -C LWRK: THE LENGTH OF VECTOR WRK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C MAXIT1: FOR IMPLICIT MODELS, THE ITERATIONS ALLOWED FOR THE NEXT -C PENALTY PARAMETER VALUE. -C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. -C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. -C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. -C N: THE NUMBER OF OBSERVATIONS. -C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS -C SUPPLIED BY THE USER. -C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. -C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. -C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. -C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. -C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. -C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. -C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. -C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. -C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE -C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, -C SET BY DJCK. -C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. -C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. -C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. -C ONE: THE VALUE 1.0D0. -C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. -C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. -C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. -C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. -C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. -C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS -C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT -C (PRTPEN=FALSE). -C P5: THE VALUE 0.5D0. -C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. -C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. -C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO -C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX -C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). -C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART -C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). -C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. -C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. -C SCLB: THE SCALING VALUES FOR BETA. -C SCLD: THE SCALING VALUES FOR DELTA. -C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. -C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED -C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-CALL -C (SHORT=FALSE). -C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. -C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. -C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. -C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. -C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. -C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. -C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. -C TEN: THE VALUE 10.0D0. -C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. -C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL -C VALUES AND THE SOLUTION. -C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. -C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. -C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. -C WD: THE DELTA WEIGHTS. -C WE: THE EPSILON WEIGHTS. -C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. -C WORK: THE DOUBLE PRECISION WORK SPACE. -C WRK: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK, -C EQUIVALENCED TO WRK1 AND WRK2. -C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. -C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. -C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. -C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. -C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. -C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. -C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. -C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. -C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. -C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. -C X: THE EXPLANATORY VARIABLE. -C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. -C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODDRV - - -C INITIALIZE NECESSARY VARIABLES - - CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, - + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) - -C SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE -C (INVALID VALUES OF M, NP AND/OR NQ ARE HANDLED REASONABLY BY DIWINF) - - CALL DIWINF(M,NP,NQ, - + MSGB,MSGD,JPVTI,ISTOPI, - + NNZWI,NPPI,IDFI, - + JOBI,IPRINI,LUNERI,LUNRPI, - + NROWI,NTOLI,NETAI, - + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, - + LIWKMN) - -C SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE -C (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE -C ARE HANDLED REASONABLY BY DWINF) - - CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, - + DELTAI,FI,XPLUSI,FNI,SDI,VCVI, - + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, - + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, - + PARTLI,SSTOLI,TAUFCI,EPSMAI, - + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, - + FSI,FJACBI,WE1I,DIFFI, - + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, - + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, - + LWKMN) - IF (ISODR) THEN - WRK = WRK1I - LWRK = N*M*NQ + N*NQ - ELSE - WRK = WRK2I - LWRK = N*NQ - END IF - -C UPDATE THE PENALTY PARAMETERS -C (WE(1,1,1) IS NOT A USER SUPPLIED ARRAY IN THIS CASE) - IF (RESTRT .AND. IMPLCT) THEN - WE(1,1,1) = MAX(WORK(WE1I)**2,ABS(WE(1,1,1))) - WORK(WE1I) = -SQRT(ABS(WE(1,1,1))) - END IF - - IF (RESTRT) THEN - -C RESET MAXIMUM NUMBER OF ITERATIONS - - IF (MAXIT.GE.0) THEN - IWORK(MAXITI) = IWORK(NITERI) + MAXIT - ELSE - IWORK(MAXITI) = IWORK(NITERI) + 10 - END IF - - IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN - INFO = 0 - END IF - - IF (JOB.GE.0) IWORK(JOBI) = JOB - IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT - IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL - IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL - - WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) - - IF (IMPLCT) THEN - CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) - ELSE - CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) - END IF - CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) - WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) - WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) - - ELSE - -C PERFORM ERROR CHECKING - - INFO = 0 - - CALL DODCHK(N,M,NP,NQ, - + ISODR,ANAJAC,IMPLCT, - + IFIXB, - + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, - + LDY, - + LWORK,LWKMN,LIWORK,LIWKMN, - + SCLB,SCLD,STPB,STPD, - + INFO) - IF (INFO.GT.0) THEN - GO TO 50 - END IF - -C INITIALIZE WORK VECTORS AS NECESSARY - - DO 10 I=N*M+N*NQ+1,LWORK - WORK(I) = ZERO - 10 CONTINUE - DO 20 I=1,LIWORK - IWORK(I) = 0 - 20 CONTINUE - - CALL DINIWK(N,M,NP, - + WORK,LWORK,IWORK,LIWORK, - + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, - + BETA,SCLB, - + SSTOL,PARTOL,MAXIT,TAUFAC, - + JOB,IPRINT,LUNERR,LUNRPT, - + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, - + JOBI,IPRINI,LUNERI,LUNRPI, - + SSFI,TTI,LDTTI,DELTAI) - - IWORK(MSGB) = -1 - IWORK(MSGD) = -1 - WORK(TAUI) = -WORK(TAUFCI) - -C SET UP FOR PARAMETER ESTIMATION - -C PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES -C AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY - - CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) - CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) - NPP = IWORK(NPPI) - -C CHECK THAT WD IS POSITIVE DEFINITE AND WE IS POSITIVE SEMIDEFINITE, -C SAVING FACTORIZATION OF WE, AND COUNTING NUMBER OF NONZERO WEIGHTS - - CALL DFCTRW(N,M,NQ,NPP, - + ISODR, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, - + WORK(WRK2I),WORK(WRK4I), - + WORK(WE1I),NNZW,INFO) - IWORK(NNZWI) = NNZW - - IF (INFO.NE.0) THEN - GO TO 50 - END IF - -C EVALUATE THE PREDICTED VALUES AND -C WEIGHTED EPSILONS AT THE STARTING POINT - - CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB) - CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N) - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,WORK(XPLUSI), - + IFIXB,IFIXX,LDIFX, - + 002,WORK(FNI),WORK(WRK6I),WORK(WRK1I), - + ISTOP) - IWORK(ISTOPI) = ISTOP - IF (ISTOP.EQ.0) THEN - IWORK(NFEVI) = IWORK(NFEVI) + 1 - IF (IMPLCT) THEN - CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) - ELSE - CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) - END IF - CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) - ELSE - INFO = 52000 - GO TO 50 - END IF - -C COMPUTE NORM OF THE INITIAL ESTIMATES - - CALL DWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP, - + WORK(WRK),NPP) - IF (ISODR) THEN - CALL DWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N, - + WORK(WRK+NPP),N) - WORK(PNORMI) = DNRM2(NPP+N*M,WORK(WRK),1) - ELSE - WORK(PNORMI) = DNRM2(NPP,WORK(WRK),1) - END IF - -C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS - - WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) - IF (ISODR) THEN - CALL DWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N) - WORK(WSSDEI) = DDOT(N*M,WORK(DELTAI),1,WORK(WRK),1) - ELSE - WORK(WSSDEI) = ZERO - END IF - WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) - -C SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS - - NROW = -1 - CALL DSETN(N,M,WORK(XPLUSI),N,NROW) - IWORK(NROWI) = NROW - -C SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS - - EPSMAC = WORK(EPSMAI) - IF (NDIGIT.LT.2) THEN - IWORK(NETAI) = -1 - NFEV = IWORK(NFEVI) - CALL DETAF(FCN, - + N,M,NP,NQ, - + WORK(XPLUSI),BETA,EPSMAC,NROW, - + WORK(BETANI),WORK(FNI), - + IFIXB,IFIXX,LDIFX, - + ISTOP,NFEV,ETA,NETA, - + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I)) - IWORK(ISTOPI) = ISTOP - IWORK(NFEVI) = NFEV - IF (ISTOP.NE.0) THEN - INFO = 53000 - IWORK(NETAI) = 0 - WORK(ETAI) = ZERO - GO TO 50 - ELSE - IWORK(NETAI) = -NETA - WORK(ETAI) = ETA - END IF - ELSE - IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC))) - WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT)) - END IF - -C CHECK DERIVATIVES IF NECESSARY - - IF (CHKJAC .AND. ANAJAC) THEN - NTOL = -1 - NFEV = IWORK(NFEVI) - NJEV = IWORK(NJEVI) - NETA = IWORK(NETAI) - LDTT = IWORK(LDTTI) - ETA = WORK(ETAI) - EPSMAC = WORK(EPSMAI) - CALL DJCK(FCN, - + N,M,NP,NQ, - + BETA,WORK(XPLUSI), - + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, - + WORK(SSFI),WORK(TTI),LDTT, - + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, - + WORK(FNI),WORK(FJACBI),WORK(FJACDI), - + IWORK(MSGB),IWORK(MSGD),WORK(DIFFI), - + ISTOP,NFEV,NJEV, - + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I)) - IWORK(ISTOPI) = ISTOP - IWORK(NFEVI) = NFEV - IWORK(NJEVI) = NJEV - IWORK(NTOLI) = NTOL - IF (ISTOP.NE.0) THEN - INFO = 54000 - ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN - INFO = 40000 - END IF - ELSE - -C INDICATE USER SUPPLIED DERIVATIVES WERE NOT CHECKED - IWORK(MSGB) = -1 - IWORK(MSGD) = -1 - END IF - -C PRINT APPROPRIATE ERROR MESSAGES - - 50 IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN - IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN - CALL DODPER - + (INFO,LUNERR,SHORT, - + N,M,NP,NQ, - + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, - + LWKMN,LIWKMN, - + WORK(FJACBI),WORK(FJACDI), - + WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD), - + WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) - END IF - -C SET INFO TO REFLECT ERRORS IN THE USER SUPPLIED JACOBIANS - - IF (INFO.EQ.40000) THEN - IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN - IF (IWORK(MSGB).EQ.2) THEN - INFO = INFO + 1000 - END IF - IF (IWORK(MSGD).EQ.2) THEN - INFO = INFO + 100 - END IF - ELSE - INFO = 0 - END IF - END IF - IF (INFO.NE.0) THEN - RETURN - END IF - END IF - END IF - -C SAVE THE INITIAL VALUES OF BETA - CALL DCOPY(NP,BETA,1,WORK(BETA0I),1) - -C FIND LEAST SQUARES SOLUTION - - CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FSI),1) - LDTT = IWORK(LDTTI) - CALL DODMN(HEAD,FSTITR,PRTPEN, - + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, - + WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD, - + IFIXB,IFIXX,LDIFX, - + WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI), - + WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), - + WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), - + WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD), - + WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, - + STPB,STPD,LDSTPD, - + WORK(XPLUSI),WORK(WRK),LWRK, - + WORK,LWORK,IWORK,LIWORK,INFO) - MAXIT1 = IWORK(MAXITI) - IWORK(NITERI) - TSTIMP = ZERO - DO 100 K=1,NP - IF (BETA(K).EQ.ZERO) THEN - TSTIMP = MAX(TSTIMP, - + ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K)) - ELSE - TSTIMP = MAX(TSTIMP, - + ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K))) - END IF - 100 CONTINUE - - RETURN - - END -*DODLM - SUBROUTINE DODLM - + (N,M,NP,NQ,NPP, - + F,FJACB,FJACD, - + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, - + ALPHA2,TAU,EPSFCN,ISODR, - + TFJACB,OMEGA,U,QRAUX,JPVT, - + S,T,NLMS,RCOND,IRANK, - + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) -C***BEGIN PROLOGUE DODLM -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DDOT,DNRM2,DODSTP,DSCALE,DWGHT -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T -C USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT -C ALGORITHM -C***END PROLOGUE DODLM - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + ALPHA2,EPSFCN,RCOND,TAU - INTEGER - + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ - LOGICAL - + ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), - + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), - + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), - + WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M) - INTEGER - + JPVT(NP) - -C...LOCAL SCALARS - DOUBLE PRECISION - + ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO - INTEGER - + I,IWRK,J,K,L - LOGICAL - + FORVCV - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DDOT,DNRM2 - EXTERNAL - + DDOT,DNRM2 - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DODSTP,DSCALE,DWGHT - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,MAX,MIN,SQRT - -C...DATA STATEMENTS - DATA - + ZERO,P001,P1 - + /0.0D0,0.001D0,0.1D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ALPHAN: THE NEW LEVENBERG-MARQUARDT PARAMETER. -C ALPHA1: THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER. -C ALPHA2: THE CURRENT LEVENBERG-MARQUARDT PARAMETER. -C BOT: THE LOWER LIMIT FOR SETTING ALPHA. -C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C EPSFCN: THE FUNCTION'S PRECISION. -C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS -C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS -C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). -C I: AN INDEXING VARIABLE. -C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE -C STOPED DUE TO SOME NUMERICAL ERROR DETECTED WITHIN -C SUBROUTINE DODSTP. -C IWRK: AN INDEXING VARIABLE. -C J: AN INDEXING VARIABLE. -C K: AN INDEXING VARIABLE. -C L: AN INDEXING VARIABLE. -C JPVT: THE PIVOT VECTOR. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LWRK: THE LENGTH OF VECTOR WRK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C OMEGA: THE ARRAY (I-FJACD*INV(P)*TRANS(FJACD))**(-1/2) WHERE -C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 -C P001: THE VALUE 0.001D0 -C P1: THE VALUE 0.1D0 -C PHI1: THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP -C AND THE TRUST REGION DIAMETER. -C PHI2: THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP -C AND THE TRUST REGION DIAMETER. -C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE -C Q-R DECOMPOSITION. -C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. -C S: THE STEP FOR BETA. -C SA: THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). -C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. -C T: THE STEP FOR DELTA. -C TAU: THE TRUST REGION DIAMETER. -C TFJACB: THE ARRAY OMEGA*FJACB. -C TOP: THE UPPER LIMIT FOR SETTING ALPHA. -C TT: THE SCALE USED FOR THE DELTA'S. -C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. -C WD: THE DELTA WEIGHTS. -C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, -C EQUIVALENCED TO WRK1 AND WRK2. -C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK3: A WORK ARRAY OF (NP) ELEMENTS. -C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. -C WRK5: A WORK ARRAY OF (M) ELEMENTS. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODLM - - FORVCV = .FALSE. - ISTOPC = 0 - -C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0) - - ALPHA1 = ZERO - CALL DODSTP(N,M,NP,NQ,NPP, - + F,FJACB,FJACD, - + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, - + ALPHA1,EPSFCN,ISODR, - + TFJACB,OMEGA,U,QRAUX,JPVT, - + S,T,PHI1,IRANK,RCOND,FORVCV, - + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) - IF (ISTOPC.NE.0) THEN - RETURN - END IF - -C INITIALIZE TAU IF NECESSARY - - IF (TAU.LT.ZERO) THEN - TAU = ABS(TAU)*PHI1 - END IF - -C CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL - - IF ((PHI1-TAU).LE.P1*TAU) THEN - NLMS = 1 - ALPHA2 = ZERO - RETURN - END IF - -C FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION - -C FIND LOCALLY CONSTRAINED OPTIMAL STEP - - PHI1 = PHI1 - TAU - -C INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA - - BOT = ZERO - - DO 30 K=1,NPP - DO 20 L=1,NQ - DO 10 I=1,N - TFJACB(I,L,K) = FJACB(I,K,L) - 10 CONTINUE - 20 CONTINUE - WRK(K) = DDOT(N*NQ,TFJACB(1,1,K),1,F(1,1),1) - 30 CONTINUE - CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP) - - IF (ISODR) THEN - CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(NPP+1),N) - IWRK = NPP - DO 50 J=1,M - DO 40 I=1,N - IWRK = IWRK + 1 - WRK(IWRK) = WRK(IWRK) + - + DDOT(NQ,FJACD(I,J,1),N*M,F(I,1),N) - 40 CONTINUE - 50 CONTINUE - CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N) - TOP = DNRM2(NPP+N*M,WRK,1)/TAU - ELSE - TOP = DNRM2(NPP,WRK,1)/TAU - END IF - - IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN - ALPHA2 = P001*TOP - END IF - -C MAIN LOOP - - DO 60 I=1,10 - -C COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR -C CURRENT VALUE OF ALPHA - - CALL DODSTP(N,M,NP,NQ,NPP, - + F,FJACB,FJACD, - + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, - + ALPHA2,EPSFCN,ISODR, - + TFJACB,OMEGA,U,QRAUX,JPVT, - + S,T,PHI2,IRANK,RCOND,FORVCV, - + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) - IF (ISTOPC.NE.0) THEN - RETURN - END IF - PHI2 = PHI2-TAU - -C CHECK WHETHER CURRENT STEP IS OPTIMAL - - IF (ABS(PHI2).LE.P1*TAU .OR. - + (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN - NLMS = I+1 - RETURN - END IF - -C CURRENT STEP IS NOT OPTIMAL - -C UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA - - IF (PHI1-PHI2.EQ.ZERO) THEN - NLMS = 12 - RETURN - END IF - SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) - IF (PHI2.LT.ZERO) THEN - TOP = MIN(TOP,ALPHA2) - ELSE - BOT = MAX(BOT,ALPHA2) - END IF - IF (PHI1*PHI2.GT.ZERO) THEN - BOT = MAX(BOT,ALPHA2-SA) - ELSE - TOP = MIN(TOP,ALPHA2-SA) - END IF - - ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU - IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN - ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) - END IF - -C GET READY FOR NEXT ITERATION - - ALPHA1 = ALPHA2 - ALPHA2 = ALPHAN - PHI1 = PHI2 - 60 CONTINUE - -C SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS - - NLMS = 12 - - RETURN - END -*DODMN - SUBROUTINE DODMN - + (HEAD,FSTITR,PRTPEN, - + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, - + WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD, - + IFIXB,IFIXX,LDIFX, - + BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS, - + T,F,FN,FS,FJACB,MSGB,FJACD,MSGD, - + SSF,SS,TT,LDTT,STPB,STPD,LDSTPD, - + XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO) -C***BEGIN PROLOGUE DODMN -C***REFER TO DODR,DODRC -C***ROUTINES CALLED FCN,DACCES,DCOPY,DDOT,DEVJAC,DFLAGS,DNRM2,DODLM, -C DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION -C***END PROLOGUE DODMN - -C...SCALAR ARGUMENTS - INTEGER - + INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, - + LIWORK,LWORK,LWRK,M,N,NP,NQ - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), - + DELTA(N,M),DELTAN(N,M),DELTAS(N,M), - + F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ), - + S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M), - + T(N,M),TT(LDTT,M), - + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ), - + WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK), - + MSGB(NQ*NP+1),MSGD(NQ*M+1) - LOGICAL - + FSTITR,HEAD,PRTPEN - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE, - + P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, - + RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC, - + TEMP,TEMP1,TEMP2,TSNORM,ZERO - INTEGER - + I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK, - + ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT, - + MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,OMEGA,QRAUX, - + SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 - LOGICAL - + ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV, - + IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT - -C...LOCAL ARRAYS - DOUBLE PRECISION - + WSS(3) - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DDOT,DNRM2 - EXTERNAL - + DDOT,DNRM2 - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DACCES,DCOPY,DEVJAC,DFLAGS, - + DODLM,DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,MIN,MOD,SQRT - -C...DATA STATEMENTS - DATA - + ZERO,P0001,P1,P25,P5,P75,ONE - + /0.0D0,0.00010D0,0.10D0,0.250D0, - + 0.50D0,0.750D0,1.0D0/ - DATA - + LUDFLT - + /6/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE -C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN -C THEM (ACCESS=FALSE). -C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. -C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED -C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). -C BETA: THE FUNCTION PARAMETERS. -C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. -C BETAN: THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. -C BETAS: THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. -C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED -C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD -C DIFFERENCES (CDJAC=FALSE). -C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED -C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT -C (CHKJAC=FALSE). -C CNVPAR: THE VARIABLE DESIGNATING WHETHER PARAMETER CONVERGENCE WAS -C ATTAINED (CNVPAR=TRUE) OR NOT (CNVPAR=FALSE). -C CNVSS: THE VARIABLE DESIGNATING WHETHER SUM-OF-SQUARES CONVERGENCE -C WAS ATTAINED (CNVSS=TRUE) OR NOT (CNVSS=FALSE). -C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C DELTAN: THE NEW ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C DELTAS: THE SAVED ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS -C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). -C DIRDER: THE DIRECTIONAL DERIVATIVE. -C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX -C SHOULD TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). -C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. -C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. -C FS: THE SAVED PREDICTED VALUES FROM THE FUNCTION. -C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST -C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). -C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE -C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). -C I: AN INDEXING VARIABLE. -C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF -C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE -C NUMBER OF PARAMETERS BEING ESTIMATED. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFLAG: THE VARIABLE DESIGNATING WHICH REPORT IS TO BE PRINTED. -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO -C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M -C ELEMENTS OF ARRAY WORK (INITD=FALSE). -C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN. -C INTDBL: THE VARIABLE DESIGNATING WHETHER INTERNAL DOUBLING IS TO BE -C USED (INTDBL=TRUE) OR NOT (INTDBL=FALSE). -C IPR: THE VALUES DESIGNATING THE LENGTH OF THE PRINTED REPORT. -C IPR1: THE VALUE OF THE 4TH DIGIT (FROM THE RIGHT) OF IPRINT, -C WHICH CONTROLS THE INITIAL SUMMARY REPORT. -C IPR2: THE VALUE OF THE 3RD DIGIT (FROM THE RIGHT) OF IPRINT, -C WHICH CONTROLS THE ITERATION REPORT. -C IPR2F: THE VALUE OF THE 2ND DIGIT (FROM THE RIGHT) OF IPRINT, -C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. -C IPR3: THE VALUE OF THE 1ST DIGIT (FROM THE RIGHT) OF IPRINT, -C WHICH CONTROLS THE FINAL SUMMARY REPORT. -C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR OLS (ISODR=FALSE). -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE -C STOPED DUE TO SOME NUMERICAL ERROR WITHIN ROUTINE DODSTP. -C IWORK: THE INTEGER WORK SPACE. -C IWRK: AN INDEX VARIABLE. -C J: AN INDEX VARIABLE. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C JPVT: THE STARTING LOCATION IN IWORK OF ARRAY JPVT. -C L: AN INDEX VARIABLE. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE AND WE1. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE AND WE1. -C LIWORK: THE LENGTH OF VECTOR IWORK. -C LOOPED: A COUNTER USED TO DETERMINE HOW MANY TIMES THE SUBLOOP -C HAS BEEN EXECUTED, WHERE IF THE COUNT BECOMES LARGE -C ENOUGH THE COMPUTATIONS WILL BE STOPPED. -C LSTEP: THE VARIABLE DESIGNATING WHETHER A SUCCESSFUL STEP HAS -C BEEN FOUND (LSTEP=TRUE) OR NOT (LSTEP=FALSE). -C LUDFLT: THE DEFAULT LOGICAL UNIT NUMBER, USED FOR COMPUTATION -C REPORTS TO THE SCREEN. -C LUNR: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C LWORK: THE LENGTH OF VECTOR WORK. -C LWRK: THE LENGTH OF VECTOR WRK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. -C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NITER: THE NUMBER OF ITERATIONS TAKEN. -C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. -C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. -C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C NPR: THE NUMBER OF TIMES THE REPORT IS TO BE WRITTEN. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER -C ITERATION. -C OMEGA: THE STARTING LOCATION IN WORK OF ARRAY OMEGA. -C ONE: THE VALUE 1.0D0. -C P0001: THE VALUE 0.0001D0. -C P1: THE VALUE 0.1D0. -C P25: THE VALUE 0.25D0. -C P5: THE VALUE 0.5D0. -C P75: THE VALUE 0.75D0. -C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. -C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. -C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C PRERS: THE OLD PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO -C BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT -C (PRTPEN=FALSE). -C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. -C RATIO: THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED -C RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. -C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO -C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX -C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). -C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART -C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). -C RNORM: THE NORM OF THE WEIGHTED ERRORS. -C RNORMN: THE NEW NORM OF THE WEIGHTED ERRORS. -C RNORMS: THE SAVED NORM OF THE WEIGHTED ERRORS. -C RSS: THE RESIDUAL SUM OF SQUARES. -C RVAR: THE RESIDUAL VARIANCE. -C S: THE STEP FOR BETA. -C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. -C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. -C SSF: THE SCALING VALUES USED FOR BETA. -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. -C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO EACH BETA. -C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C T: THE STEP FOR DELTA. -C TAU: THE TRUST REGION DIAMETER. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C TEMP: A TEMPORARY STORAGE LOCATION. -C TEMP1: A TEMPORARY STORAGE LOCATION. -C TEMP2: A TEMPORARY STORAGE LOCATION. -C TSNORM: THE NORM OF THE SCALED STEP. -C TT: THE SCALING VALUES USED FOR DELTA. -C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. -C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. -C WE: THE EPSILON WEIGHTS. -C WE1: THE SQUARE ROOT OF THE EPSILON WEIGHTS. -C WD: THE DELTA WEIGHTS. -C WORK: THE DOUBLE PRECISION WORK SPACE. -C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, -C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND -C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. -C WRK: A WORK ARRAY, EQUIVALENCED TO WRK1 AND WRK2 -C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. -C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. -C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. -C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. -C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. -C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. -C X: THE EXPLANATORY VARIABLE. -C XPLUSD: THE VALUES OF X + DELTA. -C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODMN - - -C INITIALIZE NECESSARY VARIABLES - - CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, - + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) - ACCESS = .TRUE. - CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, - + WORK,LWORK,IWORK,LIWORK, - + ACCESS,ISODR, - + JPVT,OMEGA,U,QRAUX,SD,VCV, - + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, - + NNZW,NPP, - + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, - + LUNRPT,IPR1,IPR2,IPR2F,IPR3, - + WSS,RVAR,IDF, - + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, - + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) - RNORM = SQRT(WSS(1)) - - DIDVCV = .FALSE. - INTDBL = .FALSE. - LSTEP = .TRUE. - -C PRINT INITIAL SUMMARY IF DESIRED - - IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN - IFLAG = 1 - IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN - NPR = 2 - ELSE - NPR = 1 - END IF - IF (IPR1.GE.6) THEN - IPR = 2 - ELSE - IPR = 2 - MOD(IPR1,2) - END IF - LUNR = LUNRPT - DO 10 I=1,NPR - CALL DODPCR(IPR,LUNR, - + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, - + N,M,NP,NQ,NPP,NNZW, - + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, - + IFIXB,IFIXX,LDIFX, - + SSF,TT,LDTT,STPB,STPD,LDSTPD, - + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, - + WSS,RVAR,IDF,WORK(SD), - + NITER,NFEV,NJEV,ACTRED,PRERED, - + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) - IF (IPR1.GE.5) THEN - IPR = 2 - ELSE - IPR = 1 - END IF - LUNR = LUDFLT - 10 CONTINUE - - END IF - -C STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION - - IF (RNORM.EQ.ZERO) THEN - INFO = 1 - OLMAVG = ZERO - ISTOP = 0 - GO TO 150 - END IF - -C STOP IF NUMBER OF ITERATIONS ALREADY EQUALS MAXIMUM PERMITTED - - IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN - ISTOP = 0 - GO TO 150 - ELSE IF (NITER.GE.MAXIT) THEN - INFO = 4 - ISTOP = 0 - GO TO 150 - END IF - -C MAIN LOOP - - 100 CONTINUE - - NITER = NITER + 1 - RNORMS = RNORM - LOOPED = 0 - -C EVALUATE JACOBIAN USING BEST ESTIMATE OF FUNCTION (FS) - - IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN - ISTOP = 0 - ELSE - CALL DEVJAC(FCN, - + ANAJAC,CDJAC, - + N,M,NP,NQ, - + BETAC,BETA,STPB, - + IFIXB,IFIXX,LDIFX, - + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, - + SSF,TT,LDTT,NETA,FS, - + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), - + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, - + NJEV,NFEV,ISTOP,INFO) - END IF - IF (ISTOP.NE.0) THEN - INFO = 51000 - GO TO 200 - ELSE IF (INFO.EQ.50300) THEN - GO TO 200 - END IF - -C SUB LOOP FOR -C INTERNAL DOUBLING OR -C COMPUTING NEW STEP WHEN OLD FAILED - - 110 CONTINUE - -C COMPUTE STEPS S AND T - - IF (LOOPED.GT.100) THEN - INFO = 60000 - GO TO 200 - ELSE - LOOPED = LOOPED + 1 - CALL DODLM(N,M,NP,NQ,NPP, - + F,FJACB,FJACD, - + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, - + ALPHA,TAU,ETA,ISODR, - + WORK(WRK6),WORK(OMEGA), - + WORK(U),WORK(QRAUX),IWORK(JPVT), - + S,T,NLMS,RCOND,IRANK, - + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), - + WORK(WRK5),WRK,LWRK,ISTOPC) - END IF - IF (ISTOPC.NE.0) THEN - INFO = ISTOPC - GO TO 200 - END IF - OLMAVG = OLMAVG+NLMS - -C COMPUTE BETAN = BETAC + S -C DELTAN = DELTA + T - - CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) - IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N) - -C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM) - - CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) - IF (ISODR) THEN - CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) - TSNORM = DNRM2(NPP+N*M,WRK,1) - ELSE - TSNORM = DNRM2(NPP,WRK,1) - END IF - -C COMPUTE SCALED PREDICTED REDUCTION - - IWRK = 0 - DO 130 L=1,NQ - DO 120 I=1,N - IWRK = IWRK + 1 - WRK(IWRK) = DDOT(NPP,FJACB(I,1,L),N,S,1) - IF (ISODR) WRK(IWRK) = WRK(IWRK) + - + DDOT(M,FJACD(I,1,L),N,T(I,1),N) - 120 CONTINUE - 130 CONTINUE - IF (ISODR) THEN - CALL DWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N) - TEMP1 = DDOT(N*NQ,WRK,1,WRK,1) + DDOT(N*M,T,1,WRK(N*NQ+1),1) - TEMP1 = SQRT(TEMP1)/RNORM - ELSE - TEMP1 = DNRM2(N*NQ,WRK,1)/RNORM - END IF - TEMP2 = SQRT(ALPHA)*TSNORM/RNORM - PRERED = TEMP1**2+TEMP2**2/P5 - - DIRDER = -(TEMP1**2+TEMP2**2) - -C EVALUATE PREDICTED VALUES AT NEW POINT - - CALL DUNPAC(NP,BETAN,BETA,IFIXB) - CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N) - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 002,FN,WORK(WRK6),WORK(WRK1), - + ISTOP) - IF (ISTOP.EQ.0) THEN - NFEV = NFEV + 1 - END IF - - IF (ISTOP.LT.0) THEN - -C SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FCN - - INFO = 51000 - GO TO 200 - ELSE IF (ISTOP.GT.0) THEN - -C SET NORM TO INDICATE STEP SHOULD BE REJECTED - - RNORMN = RNORM/(P1*P75) - ELSE - -C COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN) - - IF (IMPLCT) THEN - CALL DCOPY(N*NQ,FN,1,WRK,1) - ELSE - CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N) - END IF - CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N) - IF (ISODR) THEN - CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N) - RNORMN = SQRT(DDOT(N*NQ,WRK,1,WRK,1) + - + DDOT(N*M,DELTAN,1,WRK(N*NQ+1),1)) - ELSE - RNORMN = DNRM2(N*NQ,WRK,1) - END IF - END IF - -C COMPUTE SCALED ACTUAL REDUCTION - - IF (P1*RNORMN.LT.RNORM) THEN - ACTRED = ONE - (RNORMN/RNORM)**2 - ELSE - ACTRED = -ONE - END IF - -C COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION - - IF(PRERED .EQ. ZERO) THEN - RATIO = ZERO - ELSE - RATIO = ACTRED/PRERED - END IF - -C CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE - - IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN - ISTOP = 0 - TAU = TAU*P5 - ALPHA = ALPHA/P5 - CALL DCOPY(NPP,BETAS,1,BETAN,1) - CALL DCOPY(N*M,DELTAS,1,DELTAN,1) - CALL DCOPY(N*NQ,FS,1,FN,1) - ACTRED = ACTRS - PRERED = PRERS - RNORMN = RNORMS - RATIO = P5 - END IF - -C UPDATE STEP BOUND - - INTDBL = .FALSE. - IF (RATIO.LT.P25) THEN - IF (ACTRED.GE.ZERO) THEN - TEMP = P5 - ELSE - TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) - END IF - IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN - TEMP = P1 - END IF - TAU = TEMP*MIN(TAU,TSNORM/P1) - ALPHA = ALPHA/TEMP - - ELSE IF (ALPHA.EQ.ZERO) THEN - TAU = TSNORM/P5 - - ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN - -C STEP QUALIFIES FOR INTERNAL DOUBLING -C - UPDATE TAU AND ALPHA -C - SAVE INFORMATION FOR CURRENT POINT - - INTDBL = .TRUE. - - TAU = TSNORM/P5 - ALPHA = ALPHA*P5 - - CALL DCOPY(NPP,BETAN,1,BETAS,1) - CALL DCOPY(N*M,DELTAN,1,DELTAS,1) - CALL DCOPY(N*NQ,FN,1,FS,1) - ACTRS = ACTRED - PRERS = PRERED - RNORMS = RNORMN - END IF - -C IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS - - IF (INTDBL .AND. TAU.GT.ZERO) THEN - INT2 = INT2+1 - GO TO 110 - END IF - -C CHECK ACCEPTANCE - - IF (RATIO.GE.P0001) THEN - CALL DCOPY(N*NQ,FN,1,FS,1) - IF (IMPLCT) THEN - CALL DCOPY(N*NQ,FS,1,F,1) - ELSE - CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) - END IF - CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N) - CALL DCOPY(NPP,BETAN,1,BETAC,1) - CALL DCOPY(N*M,DELTAN,1,DELTA,1) - RNORM = RNORMN - CALL DWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP) - IF (ISODR) THEN - CALL DWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N) - PNORM = DNRM2(NPP+N*M,WRK,1) - ELSE - PNORM = DNRM2(NPP,WRK,1) - END IF - LSTEP = .TRUE. - ELSE - LSTEP = .FALSE. - END IF - -C TEST CONVERGENCE - - INFO = 0 - CNVSS = RNORM.EQ.ZERO - + .OR. - + (ABS(ACTRED).LE.SSTOL .AND. - + PRERED.LE.SSTOL .AND. - + P5*RATIO.LE.ONE) - CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT) - IF (CNVSS) INFO = 1 - IF (CNVPAR) INFO = 2 - IF (CNVSS .AND. CNVPAR) INFO = 3 - -C PRINT ITERATION REPORT - - IF (INFO.NE.0 .OR. LSTEP) THEN - IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN - IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN - IFLAG = 2 - CALL DUNPAC(NP,BETAC,BETA,IFIXB) - WSS(1) = RNORM*RNORM - IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN - NPR = 2 - ELSE - NPR = 1 - END IF - IF (IPR2.GE.6) THEN - IPR = 2 - ELSE - IPR = 2 - MOD(IPR2,2) - END IF - LUNR = LUNRPT - DO 140 I=1,NPR - CALL DODPCR(IPR,LUNR, - + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, - + N,M,NP,NQ,NPP,NNZW, - + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, - + IFIXB,IFIXX,LDIFX, - + SSF,TT,LDTT,STPB,STPD,LDSTPD, - + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, - + WSS,RVAR,IDF,WORK(SD), - + NITER,NFEV,NJEV,ACTRED,PRERED, - + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) - IF (IPR2.GE.5) THEN - IPR = 2 - ELSE - IPR = 1 - END IF - LUNR = LUDFLT - 140 CONTINUE - FSTITR = .FALSE. - PRTPEN = .FALSE. - END IF - END IF - END IF - -C CHECK IF FINISHED - - IF (INFO.EQ.0) THEN - IF (LSTEP) THEN - -C BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET - - IF (NITER.GE.MAXIT) THEN - INFO = 4 - ELSE - GO TO 100 - END IF - ELSE - -C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET - - GO TO 110 - END IF - END IF - - 150 CONTINUE - - IF (ISTOP.GT.0) INFO = INFO + 100 - -C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER - - IF (IMPLCT) THEN - CALL DCOPY(N*NQ,FS,1,F,1) - ELSE - CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) - END IF - CALL DUNPAC(NP,BETAC,BETA,IFIXB) - CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) - -C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS -C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED - - IF (DOVCV .AND. ISTOP.EQ.0) THEN - -C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED -C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED -C TO COMPUTE COVARIANCE MATRIX - - IF (REDOJ) THEN - CALL DEVJAC(FCN, - + ANAJAC,CDJAC, - + N,M,NP,NQ, - + BETAC,BETA,STPB, - + IFIXB,IFIXX,LDIFX, - + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, - + SSF,TT,LDTT,NETA,FS, - + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), - + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, - + NJEV,NFEV,ISTOP,INFO) - - - IF (ISTOP.NE.0) THEN - INFO = 51000 - GO TO 200 - ELSE IF (INFO.EQ.50300) THEN - GO TO 200 - END IF - END IF - - IF (IMPLCT) THEN - CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) - RSS = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) - ELSE - RSS = RNORM*RNORM - END IF - IF (REDOJ .OR. NITER.GE.1) THEN - CALL DODVCV(N,M,NP,NQ,NPP, - + F,FJACB,FJACD, - + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, - + ETA,ISODR, - + WORK(VCV),WORK(SD), - + WORK(WRK6),WORK(OMEGA), - + WORK(U),WORK(QRAUX),IWORK(JPVT), - + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, - + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), - + WORK(WRK5),WRK,LWRK,ISTOPC) - IF (ISTOPC.NE.0) THEN - INFO = ISTOPC - GO TO 200 - END IF - DIDVCV = .TRUE. - END IF - - END IF - -C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS - - 200 DO 210 I=0,NP-1 - WORK(WRK3+I) = IWORK(JPVT+I) - IWORK(JPVT+I) = -2 - 210 CONTINUE - IF (REDOJ .OR. NITER.GE.1) THEN - DO 220 I=0,NPP-1 - J = WORK(WRK3+I) - 1 - IF (I.LE.NPP-IRANK-1) THEN - IWORK(JPVT+J) = 1 - ELSE - IWORK(JPVT+J) = -1 - END IF - 220 CONTINUE - IF (NPP.LT.NP) THEN - J = NPP-1 - DO 230 I=NP-1,0,-1 - IF (IFIXB(I+1).EQ.0) THEN - IWORK(JPVT+I) = 0 - ELSE - IWORK(JPVT+I) = IWORK(JPVT+J) - J = J - 1 - END IF - 230 CONTINUE - END IF - END IF - -C STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER - - IF (NITER.GE.1) THEN - OLMAVG = OLMAVG/NITER - ELSE - OLMAVG = ZERO - END IF - -C COMPUTE WEIGHTED SUMS OF SQUARES FOR RETURN TO USER - - CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N) - WSS(3) = DDOT(N*NQ,WRK,1,WRK,1) - IF (ISODR) THEN - CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) - WSS(2) = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) - ELSE - WSS(2) = ZERO - END IF - WSS(1) = WSS(2) + WSS(3) - - ACCESS = .FALSE. - CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, - + WORK,LWORK,IWORK,LIWORK, - + ACCESS,ISODR, - + JPVT,OMEGA,U,QRAUX,SD,VCV, - + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, - + NNZW,NPP, - + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, - + LUNRPT,IPR1,IPR2,IPR2F,IPR3, - + WSS,RVAR,IDF, - + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, - + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) - -C ENCODE EXISTENCE OF QUESTIONABLE RESULTS INTO INFO - - IF (INFO.LE.9 .OR. INFO.GE.60000) THEN - IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN - INFO = INFO + 1000 - END IF - IF (ISTOP.NE.0) THEN - INFO = INFO + 100 - END IF - IF (IRANK.GE.1) THEN - IF (NPP.GT.IRANK) THEN - INFO = INFO + 10 - ELSE - INFO = INFO + 20 - END IF - END IF - END IF - -C PRINT FINAL SUMMARY - - IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN - IFLAG = 3 - - IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN - NPR = 2 - ELSE - NPR = 1 - END IF - IF (IPR3.GE.6) THEN - IPR = 2 - ELSE - IPR = 2 - MOD(IPR3,2) - END IF - LUNR = LUNRPT - DO 240 I=1,NPR - CALL DODPCR(IPR,LUNR, - + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, - + N,M,NP,NQ,NPP,NNZW, - + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, - + IWORK(JPVT),IFIXX,LDIFX, - + SSF,TT,LDTT,STPB,STPD,LDSTPD, - + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, - + WSS,RVAR,IDF,WORK(SD), - + NITER,NFEV,NJEV,ACTRED,PRERED, - + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) - IF (IPR3.GE.5) THEN - IPR = 2 - ELSE - IPR = 1 - END IF - LUNR = LUDFLT - 240 CONTINUE - END IF - - RETURN - - END -*DODPC1 - SUBROUTINE DODPC1 - + (IPR,LUNRPT, - + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, - + MSGB1,MSGB,MSGD1,MSGD, - + N,M,NP,NQ,NPP,NNZW, - + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, - + Y,LDY,WE,LDWE,LD2WE,PNLTY, - + BETA,IFIXB,SSF,STPB, - + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, - + WSS,WSSDEL,WSSEPS) -C***BEGIN PROLOGUE DODPC1 -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DHSTEP -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE GENERATE INITIAL SUMMARY REPORT -C***END PROLOGUE DODPC1 - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS - INTEGER - + IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, - + LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ - LOGICAL - + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),DELTA(N,M),SSF(NP),STPB(NP),STPD(LDSTPD,M), - + TT(LDTT,M),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),X(LDX,M), - + Y(LDY,NQ) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M) - -C...LOCAL SCALARS - DOUBLE PRECISION - + TEMP1,TEMP2,TEMP3,ZERO - INTEGER - + I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L - -C...LOCAL ARRAYS - CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13 - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DHSTEP - EXTERNAL - + DHSTEP - - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,MIN - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED -C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). -C BETA: THE FUNCTION PARAMETERS. -C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED -C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD DIFFERENCES -C (CDJAC=FALSE). -C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED -C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT -C (CHKJAC=FALSE). -C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS -C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). -C I: AN INDEXING VARIABLE. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO -C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M -C ELEMENTS OF ARRAY WORK (INITD=FALSE). -C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ITEMP: A TEMPORARY INTEGER VALUE. -C J: AN INDEXING VARIABLE. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C JOB1: THE 1ST DIGIT (FROM THE LEFT) OF VARIABLE JOB. -C JOB2: THE 2ND DIGIT (FROM THE LEFT) OF VARIABLE JOB. -C JOB3: THE 3RD DIGIT (FROM THE LEFT) OF VARIABLE JOB. -C JOB4: THE 4TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. -C JOB5: THE 5TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. -C L: AN INDEXING VARIABLE. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LUNRPT: THE LOGICAL UNIT NUMBER FOR THE COMPUTATION REPORTS. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. -C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. -C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. -C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. -C A NEGATIVE VALUE INDICATES THAT NETA WAS ESTIMATED BY -C ODRPACK. A POSITIVE VALUE INDICTES THE VALUE WAS SUPPLIED -C BY THE USER. -C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. -C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. -C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO -C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX -C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). -C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART -C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). -C SSF: THE SCALING VALUES FOR BETA. -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. -C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO BETA. -C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C TEMPC0: A TEMPORARY CHARACTER*2 VALUE. -C TEMPC1: A TEMPORARY CHARACTER*5 VALUE. -C TEMPC2: A TEMPORARY CHARACTER*13 VALUE. -C TEMP1: A TEMPORARY DOUBLE PRECISION VALUE. -C TEMP2: A TEMPORARY DOUBLE PRECISION VALUE. -C TEMP3: A TEMPORARY DOUBLE PRECISION VALUE. -C TT: THE SCALING VALUES FOR DELTA. -C WD: THE DELTA WEIGHTS. -C WE: THE EPSILON WEIGHTS. -C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. -C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. -C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. -C X: THE EXPLANATORY VARIABLE. -C Y: THE RESPONSE VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODPC1 - - -C PRINT PROBLEM SIZE SPECIFICATION - - WRITE (LUNRPT,1000) N,NNZW,NQ,M,NP,NPP - - -C PRINT CONTROL VALUES - - JOB1 = JOB/10000 - JOB2 = MOD(JOB,10000)/1000 - JOB3 = MOD(JOB,1000)/100 - JOB4 = MOD(JOB,100)/10 - JOB5 = MOD(JOB,10) - WRITE (LUNRPT,1100) JOB - IF (RESTRT) THEN - WRITE (LUNRPT,1110) JOB1 - ELSE - WRITE (LUNRPT,1111) JOB1 - END IF - IF (ISODR) THEN - IF (INITD) THEN - WRITE (LUNRPT,1120) JOB2 - ELSE - WRITE (LUNRPT,1121) JOB2 - END IF - ELSE - WRITE (LUNRPT,1122) JOB2,JOB5 - END IF - IF (DOVCV) THEN - WRITE (LUNRPT,1130) JOB3 - IF (REDOJ) THEN - WRITE (LUNRPT,1131) - ELSE - WRITE (LUNRPT,1132) - END IF - ELSE - WRITE (LUNRPT,1133) JOB3 - END IF - IF (ANAJAC) THEN - WRITE (LUNRPT,1140) JOB4 - IF (CHKJAC) THEN - IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN - WRITE (LUNRPT,1141) - ELSE - WRITE (LUNRPT,1142) - END IF - ELSE - WRITE (LUNRPT,1143) - END IF - ELSE IF (CDJAC) THEN - WRITE (LUNRPT,1144) JOB4 - ELSE - WRITE (LUNRPT,1145) JOB4 - END IF - IF (ISODR) THEN - IF (IMPLCT) THEN - WRITE (LUNRPT,1150) JOB5 - ELSE - WRITE (LUNRPT,1151) JOB5 - END IF - ELSE - WRITE (LUNRPT,1152) JOB5 - END IF - IF (NETA.LT.0) THEN - WRITE (LUNRPT,1200) -NETA - ELSE - WRITE (LUNRPT,1210) NETA - END IF - WRITE (LUNRPT,1300) TAUFAC - - -C PRINT STOPPING CRITERIA - - WRITE (LUNRPT,1400) SSTOL,PARTOL,MAXIT - - -C PRINT INITIAL SUM OF SQUARES - - IF (IMPLCT) THEN - WRITE (LUNRPT,1500) WSSDEL - IF (ISODR) THEN - WRITE (LUNRPT,1510) WSS,WSSEPS,PNLTY - END IF - ELSE - WRITE (LUNRPT,1600) WSS - IF (ISODR) THEN - WRITE (LUNRPT,1610) WSSDEL,WSSEPS - END IF - END IF - - - IF (IPR.GE.2) THEN - - -C PRINT FUNCTION PARAMETER DATA - - WRITE (LUNRPT,4000) - IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN - WRITE (LUNRPT,4110) - ELSE IF (ANAJAC) THEN - WRITE (LUNRPT,4120) - ELSE - WRITE (LUNRPT,4200) - END IF - DO 130 J=1,NP - IF (IFIXB(1).LT.0) THEN - TEMPC1 = ' NO' - ELSE - IF (IFIXB(J).NE.0) THEN - TEMPC1 = ' NO' - ELSE - TEMPC1 = ' YES' - END IF - END IF - IF (ANAJAC) THEN - IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN - ITEMP = -1 - DO 110 L=1,NQ - ITEMP = MAX(ITEMP,MSGB(L,J)) - 110 CONTINUE - IF (ITEMP.LE.-1) THEN - TEMPC2 = ' UNCHECKED' - ELSE IF (ITEMP.EQ.0) THEN - TEMPC2 = ' VERIFIED' - ELSE IF (ITEMP.GE.1) THEN - TEMPC2 = ' QUESTIONABLE' - END IF - ELSE - TEMPC2 = ' ' - END IF - ELSE - TEMPC2 = ' ' - END IF - IF (SSF(1).LT.ZERO) THEN - TEMP1 = ABS(SSF(1)) - ELSE - TEMP1 = SSF(J) - END IF - IF (ANAJAC) THEN - WRITE (LUNRPT,4310) J,BETA(J),TEMPC1,TEMP1,TEMPC2 - ELSE - IF (CDJAC) THEN - TEMP2 = DHSTEP(1,NETA,1,J,STPB,1) - ELSE - TEMP2 = DHSTEP(0,NETA,1,J,STPB,1) - END IF - WRITE (LUNRPT,4320) J,BETA(J),TEMPC1,TEMP1,TEMP2 - END IF - 130 CONTINUE - -C PRINT EXPLANATORY VARIABLE DATA - - IF (ISODR) THEN - WRITE (LUNRPT,2010) - IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN - WRITE (LUNRPT,2110) - ELSE IF (ANAJAC) THEN - WRITE (LUNRPT,2120) - ELSE - WRITE (LUNRPT,2130) - END IF - ELSE - WRITE (LUNRPT,2020) - WRITE (LUNRPT,2140) - END IF - IF (ISODR) THEN - DO 240 J = 1,M - TEMPC0 = '1,' - DO 230 I=1,N,N-1 - - IF (IFIXX(1,1).LT.0) THEN - TEMPC1 = ' NO' - ELSE - IF (LDIFX.EQ.1) THEN - IF (IFIXX(1,J).EQ.0) THEN - TEMPC1 = ' YES' - ELSE - TEMPC1 = ' NO' - END IF - ELSE - IF (IFIXX(I,J).EQ.0) THEN - TEMPC1 = ' YES' - ELSE - TEMPC1 = ' NO' - END IF - END IF - END IF - - IF (TT(1,1).LT.ZERO) THEN - TEMP1 = ABS(TT(1,1)) - ELSE - IF (LDTT.EQ.1) THEN - TEMP1 = TT(1,J) - ELSE - TEMP1 = TT(I,J) - END IF - END IF - - IF (WD(1,1,1).LT.ZERO) THEN - TEMP2 = ABS(WD(1,1,1)) - ELSE - IF (LDWD.EQ.1) THEN - IF (LD2WD.EQ.1) THEN - TEMP2 = WD(1,1,J) - ELSE - TEMP2 = WD(1,J,J) - END IF - ELSE - IF (LD2WD.EQ.1) THEN - TEMP2 = WD(I,1,J) - ELSE - TEMP2 = WD(I,J,J) - END IF - END IF - END IF - - IF (ANAJAC) THEN - IF (CHKJAC .AND. - + (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND. - + (I.EQ.1))) THEN - ITEMP = -1 - DO 210 L=1,NQ - ITEMP = MAX(ITEMP,MSGD(L,J)) - 210 CONTINUE - IF (ITEMP.LE.-1) THEN - TEMPC2 = ' UNCHECKED' - ELSE IF (ITEMP.EQ.0) THEN - TEMPC2 = ' VERIFIED' - ELSE IF (ITEMP.GE.1) THEN - TEMPC2 = ' QUESTIONABLE' - END IF - ELSE - TEMPC2 = ' ' - END IF - IF (M.LE.9) THEN - WRITE (LUNRPT,5110) - + TEMPC0,J,X(I,J), - + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 - ELSE - WRITE (LUNRPT,5120) - + TEMPC0,J,X(I,J), - + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 - END IF - ELSE - TEMPC2 = ' ' - IF (CDJAC) THEN - TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD) - ELSE - TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD) - END IF - IF (M.LE.9) THEN - WRITE (LUNRPT,5210) - + TEMPC0,J,X(I,J), - + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 - ELSE - WRITE (LUNRPT,5220) - + TEMPC0,J,X(I,J), - + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 - END IF - END IF - - TEMPC0 = 'N,' - - 230 CONTINUE - IF (J.LT.M) WRITE (LUNRPT,6000) - 240 CONTINUE - ELSE - - DO 260 J = 1,M - TEMPC0 = '1,' - DO 250 I=1,N,N-1 - IF (M.LE.9) THEN - WRITE (LUNRPT,5110) - + TEMPC0,J,X(I,J) - ELSE - WRITE (LUNRPT,5120) - + TEMPC0,J,X(I,J) - END IF - TEMPC0 = 'N,' - 250 CONTINUE - IF (J.LT.M) WRITE (LUNRPT,6000) - 260 CONTINUE - END IF - -C PRINT RESPONSE VARIABLE DATA AND OBSERVATION ERROR WEIGHTS - - IF (.NOT.IMPLCT) THEN - WRITE (LUNRPT,3000) - WRITE (LUNRPT,3100) - DO 310 L=1,NQ - TEMPC0 = '1,' - DO 300 I=1,N,N-1 - IF (WE(1,1,1).LT.ZERO) THEN - TEMP1 = ABS(WE(1,1,1)) - ELSE IF (LDWE.EQ.1) THEN - IF (LD2WE.EQ.1) THEN - TEMP1 = WE(1,1,L) - ELSE - TEMP1 = WE(1,L,L) - END IF - ELSE - IF (LD2WE.EQ.1) THEN - TEMP1 = WE(I,1,L) - ELSE - TEMP1 = WE(I,L,L) - END IF - END IF - IF (NQ.LE.9) THEN - WRITE (LUNRPT,5110) - + TEMPC0,L,Y(I,L),TEMP1 - ELSE - WRITE (LUNRPT,5120) - + TEMPC0,L,Y(I,L),TEMP1 - END IF - TEMPC0 = 'N,' - 300 CONTINUE - IF (L.LT.NQ) WRITE (LUNRPT,6000) - 310 CONTINUE - END IF - END IF - - RETURN - -C FORMAT STATEMENTS - - 1000 FORMAT - + (/' --- PROBLEM SIZE:'/ - + ' N = ',I5, - + ' (NUMBER WITH NONZERO WEIGHT = ',I5,')'/ - + ' NQ = ',I5/ - + ' M = ',I5/ - + ' NP = ',I5, - + ' (NUMBER UNFIXED = ',I5,')') - 1100 FORMAT - + (/' --- CONTROL VALUES:'/ - + ' JOB = ',I5.5/ - + ' = ABCDE, WHERE') - 1110 FORMAT - + (' A=',I1,' ==> FIT IS A RESTART.') - 1111 FORMAT - + (' A=',I1,' ==> FIT IS NOT A RESTART.') - 1120 FORMAT - + (' B=',I1,' ==> DELTAS ARE INITIALIZED', - + ' TO ZERO.') - 1121 FORMAT - + (' B=',I1,' ==> DELTAS ARE INITIALIZED', - + ' BY USER.') - 1122 FORMAT - + (' B=',I1,' ==> DELTAS ARE FIXED AT', - + ' ZERO SINCE E=',I1,'.') - 1130 FORMAT - + (' C=',I1,' ==> COVARIANCE MATRIX WILL', - + ' BE COMPUTED USING') - 1131 FORMAT - + (' DERIVATIVES RE-', - + 'EVALUATED AT THE SOLUTION.') - 1132 FORMAT - + (' DERIVATIVES FROM THE', - + ' LAST ITERATION.') - 1133 FORMAT - + (' C=',I1,' ==> COVARIANCE MATRIX WILL', - + ' NOT BE COMPUTED.') - 1140 FORMAT - + (' D=',I1,' ==> DERIVATIVES ARE', - + ' SUPPLIED BY USER.') - 1141 FORMAT - + (' DERIVATIVES WERE CHECKED.'/ - + ' RESULTS APPEAR QUESTIONABLE.') - 1142 FORMAT - + (' DERIVATIVES WERE CHECKED.'/ - + ' RESULTS APPEAR CORRECT.') - 1143 FORMAT - + (' DERIVATIVES WERE NOT', - + ' CHECKED.') - 1144 FORMAT - + (' D=',I1,' ==> DERIVATIVES ARE', - + ' ESTIMATED BY CENTRAL', - + ' DIFFERENCES.') - 1145 FORMAT - + (' D=',I1,' ==> DERIVATIVES ARE', - + ' ESTIMATED BY FORWARD', - + ' DIFFERENCES.') - 1150 FORMAT - + (' E=',I1,' ==> METHOD IS IMPLICIT ODR.') - 1151 FORMAT - + (' E=',I1,' ==> METHOD IS EXPLICIT ODR.') - 1152 FORMAT - + (' E=',I1,' ==> METHOD IS EXPLICIT OLS.') - 1200 FORMAT - + (' NDIGIT = ',I5,' (ESTIMATED BY ODRPACK)') - 1210 FORMAT - + (' NDIGIT = ',I5,' (SUPPLIED BY USER)') - 1300 FORMAT - + (' TAUFAC = ',1P,D12.2) - 1400 FORMAT - + (/' --- STOPPING CRITERIA:'/ - + ' SSTOL = ',1P,D12.2, - + ' (SUM OF SQUARES STOPPING TOLERANCE)'/ - + ' PARTOL = ',1P,D12.2, - + ' (PARAMETER STOPPING TOLERANCE)'/ - + ' MAXIT = ',I5, - + ' (MAXIMUM NUMBER OF ITERATIONS)') - 1500 FORMAT - + (/' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =', - + 17X,1P,D17.8) - 1510 FORMAT - + ( ' INITIAL PENALTY FUNCTION VALUE =',1P,D17.8/ - + ' PENALTY TERM =',1P,D17.8/ - + ' PENALTY PARAMETER =',1P,D10.1) - 1600 FORMAT - + (/' --- INITIAL WEIGHTED SUM OF SQUARES =', - + 17X,1P,D17.8) - 1610 FORMAT - + ( ' SUM OF SQUARED WEIGHTED DELTAS =',1P,D17.8/ - + ' SUM OF SQUARED WEIGHTED EPSILONS =',1P,D17.8) - 2010 FORMAT - + (/' --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:') - 2020 FORMAT - + (/' --- EXPLANATORY VARIABLE SUMMARY:') - 2110 FORMAT - + (/' INDEX X(I,J) DELTA(I,J) FIXED', - + ' SCALE WEIGHT DERIVATIVE'/ - + ' ', - + ' ASSESSMENT'/, - + ' (I,J) (IFIXX)', - + ' (SCLD) (WD) '/) - 2120 FORMAT - + (/' INDEX X(I,J) DELTA(I,J) FIXED', - + ' SCALE WEIGHT '/ - + ' ', - + ' '/, - + ' (I,J) (IFIXX)', - + ' (SCLD) (WD) '/) - 2130 FORMAT - + (/' INDEX X(I,J) DELTA(I,J) FIXED', - + ' SCALE WEIGHT DERIVATIVE'/ - + ' ', - + ' STEP SIZE'/, - + ' (I,J) (IFIXX)', - + ' (SCLD) (WD) (STPD)'/) - 2140 FORMAT - + (/' INDEX X(I,J)'/ - + ' (I,J) '/) - 3000 FORMAT - + (/' --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT', - + ' SUMMARY:') - 3100 FORMAT - + (/' INDEX Y(I,L) WEIGHT'/ - + ' (I,L) (WE)'/) - 4000 FORMAT - + (/' --- FUNCTION PARAMETER SUMMARY:') - 4110 FORMAT - + (/' INDEX BETA(K) FIXED SCALE', - + ' DERIVATIVE'/ - + ' ', - + ' ASSESSMENT'/, - + ' (K) (IFIXB) (SCLB)', - + ' '/) - 4120 FORMAT - + (/' INDEX BETA(K) FIXED SCALE', - + ' '/ - + ' ', - + ' '/, - + ' (K) (IFIXB) (SCLB)', - + ' '/) - 4200 FORMAT - + (/' INDEX BETA(K) FIXED SCALE', - + ' DERIVATIVE'/ - + ' ', - + ' STEP SIZE'/, - + ' (K) (IFIXB) (SCLB)', - + ' (STPB)'/) - 4310 FORMAT - + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,A13) - 4320 FORMAT - + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,D13.5) - 5110 FORMAT - + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,A13) - 5120 FORMAT - + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,A13) - 5210 FORMAT - + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) - 5220 FORMAT - + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) - 6000 FORMAT - + (' ') - END -*DODPC2 - SUBROUTINE DODPC2 - + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, - + PNLTY, - + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) -C***BEGIN PROLOGUE DODPC2 -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE GENERATE ITERATION REPORTS -C***END PROLOGUE DODPC2 - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS - INTEGER - + IPR,LUNRPT,NFEV,NITER,NP - LOGICAL - + FSTITR,IMPLCT,PRTPEN - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP) - -C...LOCAL SCALARS - DOUBLE PRECISION - + RATIO,ZERO - INTEGER - + J,K,L - CHARACTER GN*3 - -C...INTRINSIC FUNCTIONS - INTRINSIC - + MIN - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. -C BETA: THE FUNCTION PARAMETERS. -C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST -C ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). -C GN: THE CHARACTER*3 VARIABLE INDICATING WHETHER A GAUSS-NEWTON -C STEP WAS TAKEN. -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. -C J: AN INDEXING VARIABLE. -C K: AN INDEXING VARIABLE. -C L: AN INDEXING VARIABLE. -C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NITER: THE NUMBER OF ITERATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. -C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. -C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS -C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT -C (PRTPEN=FALSE). -C RATIO: THE RATIO OF TAU TO PNORM. -C TAU: THE TRUST REGION DIAMETER. -C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODPC2 - - - IF (FSTITR) THEN - IF (IPR.EQ.1) THEN - IF (IMPLCT) THEN - WRITE (LUNRPT,1121) - ELSE - WRITE (LUNRPT,1122) - END IF - ELSE - IF (IMPLCT) THEN - WRITE (LUNRPT,1131) - ELSE - WRITE (LUNRPT,1132) - END IF - END IF - END IF - IF (PRTPEN) THEN - WRITE (LUNRPT,1133) PNLTY - END IF - - IF (ALPHA.EQ.ZERO) THEN - GN = 'YES' - ELSE - GN = ' NO' - END IF - IF (PNORM.NE.ZERO) THEN - RATIO = TAU/PNORM - ELSE - RATIO = ZERO - END IF - IF (IPR.EQ.1) THEN - WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, - + RATIO,GN - ELSE - J = 1 - K = MIN(3,NP) - IF (J.EQ.K) THEN - WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, - + RATIO,GN,J,BETA(J) - ELSE - WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, - + RATIO,GN,J,K,(BETA(L),L=J,K) - END IF - IF (NP.GT.3) THEN - DO 10 J=4,NP,3 - K = MIN(J+2,NP) - IF (J.EQ.K) THEN - WRITE (LUNRPT,1151) J,BETA(J) - ELSE - WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) - END IF - 10 CONTINUE - END IF - END IF - - RETURN - -C FORMAT STATEMENTS - - 1121 FORMAT - + (// - + ' CUM. PENALTY ACT. REL. PRED. REL.'/ - + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', - + ' G-N'/ - + ' NUM. EVALS VALUE REDUCTION REDUCTION', - + ' TAU/PNORM STEP'/ - + ' ---- ------ ----------- ----------- -----------', - + ' --------- ----') - 1122 FORMAT - + (// - + ' CUM. ACT. REL. PRED. REL.'/ - + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', - + ' G-N'/ - + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', - + ' TAU/PNORM STEP'/ - + ' ---- ------ ----------- ----------- -----------', - + ' --------- ----'/) - 1131 FORMAT - + (// - + ' CUM. PENALTY ACT. REL. PRED. REL.'/ - + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', - + ' G-N BETA -------------->'/ - + ' NUM. EVALS VALUE REDUCTION REDUCTION', - + ' TAU/PNORM STEP INDEX VALUE'/ - + ' ---- ------ ----------- ----------- -----------', - + ' --------- ---- ----- -----') - 1132 FORMAT - + (// - + ' CUM. ACT. REL. PRED. REL.'/ - + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', - + ' G-N BETA -------------->'/ - + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', - + ' TAU/PNORM STEP INDEX VALUE'/ - + ' ---- ------ ----------- ----------- -----------', - + ' --------- ---- ----- -----'/) - 1133 FORMAT - + (/' PENALTY PARAMETER VALUE = ', 1P,E10.1) - 1141 FORMAT - + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8) - 1142 FORMAT - + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8) - 1151 FORMAT - + (76X,I3,1P,D16.8) - 1152 FORMAT - + (70X,I3,' TO',I3,1P,3D16.8) - END -*DODPC3 - SUBROUTINE DODPC3 - + (IPR,LUNRPT, - + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, - + N,M,NP,NQ,NPP, - + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, - + WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF, - + BETA,SDBETA,IFIXB2,F,DELTA) -C***BEGIN PROLOGUE DODPC3 -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DPPT -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE GENERATE FINAL SUMMARY REPORT -C***END PROLOGUE DODPC3 - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS - INTEGER - + IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M, - + N,NFEV,NITER,NJEV,NP,NPP,NQ - LOGICAL - + ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP) - INTEGER - + IFIXB2(NP) - -C...LOCAL SCALARS - DOUBLE PRECISION - + TVAL - INTEGER - + D1,D2,D3,D4,D5,I,J,K,L,NPLM1 - CHARACTER FMT1*90 - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DPPT - EXTERNAL - + DPPT - -C...INTRINSIC FUNCTIONS - INTRINSIC - + MIN,MOD - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED -C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). -C BETA: THE FUNCTION PARAMETERS. -C D1: THE FIRST DIGIT OF INFO. -C D2: THE SECOND DIGIT OF INFO. -C D3: THE THIRD DIGIT OF INFO. -C D4: THE FOURTH DIGIT OF INFO. -C D5: THE FIFTH DIGIT OF INFO. -C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS -C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). -C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS -C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). -C F: THE ESTIMATED VALUES OF EPSILON. -C FMT1: A CHARACTER*90 VARIABLE USED FOR FORMATS. -C I: AN INDEXING VARIABLE. -C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF -C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE -C NUMBER OF PARAMETERS BEING ESTIMATED. -C IFIXB2: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA WERE -C ESTIMATED, FIXED, OR DROPPED BECAUSE THEY CAUSED RANK -C DEFICIENCY, CORRESPONDING TO VALUES OF IFIXB2 EQUALING 1, -C 0, AND -1, RESPECTIVELY. IF IFIXB2 IS -2, THEN NO ATTEMPT -C WAS MADE TO ESTIMATE THE PARAMETERS BECAUSE MAXIT = 0. -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C IPR: THE VARIABLE INDICATING WHAT IS TO BE PRINTED. -C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C J: AN INDEXING VARIABLE. -C K: AN INDEXING VARIABLE. -C L: AN INDEXING VARIABLE. -C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NITER: THE NUMBER OF ITERATIONS. -C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPLM1: THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE. -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. -C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. -C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS -C TO BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE -C MATRIX (REDOJ=TRUE) OR NOT (REDOJ=FALSE). -C RVAR: THE RESIDUAL VARIANCE. -C SDBETA: THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS. -C TVAL: THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE -C T DISTRIBUTION. -C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. -C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. -C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. - - -C***FIRST EXECUTABLE STATEMENT DODPC3 - - - D1 = INFO/10000 - D2 = MOD(INFO,10000)/1000 - D3 = MOD(INFO,1000)/100 - D4 = MOD(INFO,100)/10 - D5 = MOD(INFO,10) - -C PRINT STOPPING CONDITIONS - - WRITE (LUNRPT,1000) - IF (INFO.LE.9) THEN - IF (INFO.EQ.1) THEN - WRITE (LUNRPT,1011) INFO - ELSE IF (INFO.EQ.2) THEN - WRITE (LUNRPT,1012) INFO - ELSE IF (INFO.EQ.3) THEN - WRITE (LUNRPT,1013) INFO - ELSE IF (INFO.EQ.4) THEN - WRITE (LUNRPT,1014) INFO - ELSE IF (INFO.LE.9) THEN - WRITE (LUNRPT,1015) INFO - END IF - ELSE IF (INFO.LE.9999) THEN - -C PRINT WARNING DIAGNOSTICS - - WRITE (LUNRPT,1020) INFO - IF (D2.EQ.1) WRITE (LUNRPT,1021) - IF (D3.EQ.1) WRITE (LUNRPT,1022) - IF (D4.EQ.1) WRITE (LUNRPT,1023) - IF (D4.EQ.2) WRITE (LUNRPT,1024) - IF (D5.EQ.1) THEN - WRITE (LUNRPT,1031) - ELSE IF (D5.EQ.2) THEN - WRITE (LUNRPT,1032) - ELSE IF (D5.EQ.3) THEN - WRITE (LUNRPT,1033) - ELSE IF (D5.EQ.4) THEN - WRITE (LUNRPT,1034) - ELSE IF (D5.LE.9) THEN - WRITE (LUNRPT,1035) D5 - END IF - ELSE - -C PRINT ERROR MESSAGES - - WRITE (LUNRPT,1040) INFO - IF (D1.EQ.5) THEN - WRITE (LUNRPT,1042) - IF (D2.NE.0) WRITE (LUNRPT,1043) D2 - IF (D3.EQ.3) THEN - WRITE (LUNRPT,1044) D3 - ELSE IF (D3.NE.0) THEN - WRITE (LUNRPT,1045) D3 - END IF - ELSE IF (D1.EQ.6) THEN - WRITE (LUNRPT,1050) - ELSE - WRITE (LUNRPT,1060) D1 - END IF - END IF - -C PRINT MISC. STOPPING INFO - - WRITE (LUNRPT,1300) NITER - WRITE (LUNRPT,1310) NFEV - IF (ANAJAC) WRITE (LUNRPT,1320) NJEV - WRITE (LUNRPT,1330) IRANK - WRITE (LUNRPT,1340) RCOND - WRITE (LUNRPT,1350) ISTOP - -C PRINT FINAL SUM OF SQUARES - - IF (IMPLCT) THEN - WRITE (LUNRPT,2000) WSSDEL - IF (ISODR) THEN - WRITE (LUNRPT,2010) WSS,WSSEPS,PNLTY - END IF - ELSE - WRITE (LUNRPT,2100) WSS - IF (ISODR) THEN - WRITE (LUNRPT,2110) WSSDEL,WSSEPS - END IF - END IF - IF (DIDVCV) THEN - WRITE (LUNRPT,2200) SQRT(RVAR),IDF - END IF - - NPLM1 = 3 - -C PRINT ESTIMATED BETA'S, AND, -C IF, FULL RANK, THEIR STANDARD ERRORS - - WRITE (LUNRPT,3000) - IF (DIDVCV) THEN - WRITE (LUNRPT,7300) - TVAL = DPPT(0.975D0,IDF) - DO 10 J=1,NP - IF (IFIXB2(J).GE.1) THEN - WRITE (LUNRPT,8400) J,BETA(J),SDBETA(J), - + BETA(J)-TVAL*SDBETA(J), - + BETA(J)+TVAL*SDBETA(J) - ELSE IF (IFIXB2(J).EQ.0) THEN - WRITE (LUNRPT,8600) J,BETA(J) - ELSE - WRITE (LUNRPT,8700) J,BETA(J) - END IF - 10 CONTINUE - IF (.NOT.REDOJ) WRITE (LUNRPT,7310) - ELSE - IF (DOVCV) THEN - IF (D1.LE.5) THEN - WRITE (LUNRPT,7410) - ELSE - WRITE (LUNRPT,7420) - END IF - END IF - - IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR. NITER.EQ.0) THEN - IF (NP.EQ.1) THEN - WRITE (LUNRPT,7100) - ELSE - WRITE (LUNRPT,7200) - END IF - DO 20 J=1,NP,NPLM1+1 - K = MIN(J+NPLM1,NP) - IF (K.EQ.J) THEN - WRITE (LUNRPT,8100) J,BETA(J) - ELSE - WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) - END IF - 20 CONTINUE - IF (NITER.GE.1) THEN - WRITE (LUNRPT,8800) - ELSE - WRITE (LUNRPT,8900) - END IF - ELSE - WRITE (LUNRPT,7500) - DO 30 J=1,NP - IF (IFIXB2(J).GE.1) THEN - WRITE (LUNRPT,8500) J,BETA(J) - ELSE IF (IFIXB2(J).EQ.0) THEN - WRITE (LUNRPT,8600) J,BETA(J) - ELSE - WRITE (LUNRPT,8700) J,BETA(J) - END IF - 30 CONTINUE - END IF - END IF - - IF (IPR.EQ.1) RETURN - - -C PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF -C COLUMNS OF DATA IN EPSILON AND DELTA IS LESS THAN OR EQUAL TO THREE. - - IF (IMPLCT .AND. (M.LE.4)) THEN - WRITE (LUNRPT,4100) - WRITE (FMT1,9110) M - WRITE (LUNRPT,FMT1) (J,J=1,M) - DO 40 I=1,N - WRITE (LUNRPT,4130) I,(DELTA(I,J),J=1,M) - 40 CONTINUE - - ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN - WRITE (LUNRPT,4110) - WRITE (FMT1,9120) NQ,M - WRITE (LUNRPT,FMT1) (L,L=1,NQ),(J,J=1,M) - DO 50 I=1,N - WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M) - 50 CONTINUE - - ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN - WRITE (LUNRPT,4120) - WRITE (FMT1,9130) NQ - WRITE (LUNRPT,FMT1) (L,L=1,NQ) - DO 60 I=1,N - WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ) - 60 CONTINUE - ELSE - -C PRINT EPSILON'S AND DELTA'S SEPARATELY - - IF (.NOT.IMPLCT) THEN - -C PRINT EPSILON'S - - DO 80 J=1,NQ - WRITE (LUNRPT,4200) J - IF (N.EQ.1) THEN - WRITE (LUNRPT,7100) - ELSE - WRITE (LUNRPT,7200) - END IF - DO 70 I=1,N,NPLM1+1 - K = MIN(I+NPLM1,N) - IF (I.EQ.K) THEN - WRITE (LUNRPT,8100) I,F(I,J) - ELSE - WRITE (LUNRPT,8200) I,K,(F(L,J),L=I,K) - END IF - 70 CONTINUE - 80 CONTINUE - END IF - -C PRINT DELTA'S - - IF (ISODR) THEN - DO 100 J=1,M - WRITE (LUNRPT,4300) J - IF (N.EQ.1) THEN - WRITE (LUNRPT,7100) - ELSE - WRITE (LUNRPT,7200) - END IF - DO 90 I=1,N,NPLM1+1 - K = MIN(I+NPLM1,N) - IF (I.EQ.K) THEN - WRITE (LUNRPT,8100) I,DELTA(I,J) - ELSE - WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) - END IF - 90 CONTINUE - 100 CONTINUE - END IF - END IF - - RETURN - -C FORMAT STATEMENTS - - 1000 FORMAT - + (/' --- STOPPING CONDITIONS:') - 1011 FORMAT - + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE.') - 1012 FORMAT - + (' INFO = ',I5,' ==> PARAMETER CONVERGENCE.') - 1013 FORMAT - + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE AND', - + ' PARAMETER CONVERGENCE.') - 1014 FORMAT - + (' INFO = ',I5,' ==> ITERATION LIMIT REACHED.') - 1015 FORMAT - + (' INFO = ',I5,' ==> UNEXPECTED VALUE,', - + ' PROBABLY INDICATING'/ - + ' INCORRECTLY SPECIFIED', - + ' USER INPUT.') - 1020 FORMAT - + (' INFO = ',I5.4/ - + ' = ABCD, WHERE A NONZERO VALUE FOR DIGIT A,', - + ' B, OR C INDICATES WHY'/ - + ' THE RESULTS MIGHT BE QUESTIONABLE,', - + ' AND DIGIT D INDICATES'/ - + ' THE ACTUAL STOPPING CONDITION.') - 1021 FORMAT - + (' A=1 ==> DERIVATIVES ARE', - + ' QUESTIONABLE.') - 1022 FORMAT - + (' B=1 ==> USER SET ISTOP TO', - + ' NONZERO VALUE DURING LAST'/ - + ' CALL TO SUBROUTINE FCN.') - 1023 FORMAT - + (' C=1 ==> DERIVATIVES ARE NOT', - + ' FULL RANK AT THE SOLUTION.') - 1024 FORMAT - + (' C=2 ==> DERIVATIVES ARE ZERO', - + ' RANK AT THE SOLUTION.') - 1031 FORMAT - + (' D=1 ==> SUM OF SQUARES CONVERGENCE.') - 1032 FORMAT - + (' D=2 ==> PARAMETER CONVERGENCE.') - 1033 FORMAT - + (' D=3 ==> SUM OF SQUARES CONVERGENCE', - + ' AND PARAMETER CONVERGENCE.') - 1034 FORMAT - + (' D=4 ==> ITERATION LIMIT REACHED.') - 1035 FORMAT - + (' D=',I1,' ==> UNEXPECTED VALUE,', - + ' PROBABLY INDICATING'/ - + ' INCORRECTLY SPECIFIED', - + ' USER INPUT.') - 1040 FORMAT - + (' INFO = ',I5.5/ - + ' = ABCDE, WHERE A NONZERO VALUE FOR A GIVEN', - + ' DIGIT INDICATES AN'/ - + ' ABNORMAL STOPPING CONDITION.') - 1042 FORMAT - + (' A=5 ==> USER STOPPED COMPUTATIONS', - + ' IN SUBROUTINE FCN.') - 1043 FORMAT - + (' B=',I1,' ==> COMPUTATIONS WERE', - + ' STOPPED DURING THE'/ - + ' FUNCTION EVALUATION.') - 1044 FORMAT - + (' C=',I1,' ==> COMPUTATIONS WERE', - + ' STOPPED BECAUSE'/ - + ' DERIVATIVES WITH', - + ' RESPECT TO DELTA WERE'/ - + ' COMPUTED BY', - + ' SUBROUTINE FCN WHEN'/ - + ' FIT IS OLS.') - 1045 FORMAT - + (' C=',I1,' ==> COMPUTATIONS WERE', - + ' STOPPED DURING THE'/ - + ' JACOBIAN EVALUATION.') - 1050 FORMAT - + (' A=6 ==> NUMERICAL INSTABILITIES', - + ' HAVE BEEN DETECTED,'/ - + ' POSSIBLY INDICATING', - + ' A DISCONTINUITY IN THE'/ - + ' DERIVATIVES OR A POOR', - + ' POOR CHOICE OF PROBLEM'/ - + ' SCALE OR WEIGHTS.') - 1060 FORMAT - + (' A=',I1,' ==> UNEXPECTED VALUE,', - + ' PROBABLY INDICATING'/ - + ' INCORRECTLY SPECIFIED', - + ' USER INPUT.') - 1300 FORMAT - + (' NITER = ',I5, - + ' (NUMBER OF ITERATIONS)') - 1310 FORMAT - + (' NFEV = ',I5, - + ' (NUMBER OF FUNCTION EVALUATIONS)') - 1320 FORMAT - + (' NJEV = ',I5, - + ' (NUMBER OF JACOBIAN EVALUATIONS)') - 1330 FORMAT - + (' IRANK = ',I5, - + ' (RANK DEFICIENCY)') - 1340 FORMAT - + (' RCOND = ',1P,D12.2, - + ' (INVERSE CONDITION NUMBER)') -*1341 FORMAT -* + (' ==> POSSIBLY FEWER THAN 2 SIGNIFICANT', -* + ' DIGITS IN RESULTS;'/ -* + ' SEE ODRPACK REFERENCE', -* + ' GUIDE, SECTION 4.C.') - 1350 FORMAT - + (' ISTOP = ',I5, - + ' (RETURNED BY USER FROM', - + ' SUBROUTINE FCN)') - 2000 FORMAT - + (/' --- FINAL SUM OF SQUARED WEIGHTED DELTAS = ', - + 17X,1P,D17.8) - 2010 FORMAT - + ( ' FINAL PENALTY FUNCTION VALUE = ',1P,D17.8/ - + ' PENALTY TERM = ',1P,D17.8/ - + ' PENALTY PARAMETER = ',1P,D10.1) - 2100 FORMAT - + (/' --- FINAL WEIGHTED SUMS OF SQUARES = ',17X,1P,D17.8) - 2110 FORMAT - + ( ' SUM OF SQUARED WEIGHTED DELTAS = ',1P,D17.8/ - + ' SUM OF SQUARED WEIGHTED EPSILONS = ',1P,D17.8) - 2200 FORMAT - + (/' --- RESIDUAL STANDARD DEVIATION = ', - + 17X,1P,D17.8/ - + ' DEGREES OF FREEDOM =',I5) - 3000 FORMAT - + (/' --- ESTIMATED BETA(J), J = 1, ..., NP:') - 4100 FORMAT - + (/' --- ESTIMATED DELTA(I,*), I = 1, ..., N:') - 4110 FORMAT - + (/' --- ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:') - 4120 FORMAT - + (/' --- ESTIMATED EPSILON(I), I = 1, ..., N:') - 4130 FORMAT(5X,I5,1P,5D16.8) - 4200 FORMAT - + (/' --- ESTIMATED EPSILON(I,',I3,'), I = 1, ..., N:') - 4300 FORMAT - + (/' --- ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:') - 7100 FORMAT - + (/' INDEX VALUE'/) - 7200 FORMAT - + (/' INDEX VALUE -------------->'/) - 7300 FORMAT - + (/' BETA S.D. BETA', - + ' ---- 95% CONFIDENCE INTERVAL ----'/) - 7310 FORMAT - + (/' N.B. STANDARD ERRORS AND CONFIDENCE INTERVALS ARE', - + ' COMPUTED USING'/ - + ' DERIVATIVES CALCULATED AT THE BEGINNING', - + ' OF THE LAST ITERATION,'/ - + ' AND NOT USING DERIVATIVES RE-EVALUATED AT THE', - + ' FINAL SOLUTION.') - 7410 FORMAT - + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', - + ' NOT COMPUTED BECAUSE'/ - + ' THE DERIVATIVES WERE NOT AVAILABLE. EITHER MAXIT', - + ' IS 0 AND THE THIRD'/ - + ' DIGIT OF JOB IS GREATER THAN 1, OR THE MOST', - + ' RECENTLY TRIED VALUES OF'/ - + ' BETA AND/OR X+DELTA WERE IDENTIFIED AS', - + ' UNACCEPTABLE BY USER SUPPLIED'/ - + ' SUBROUTINE FCN.') - 7420 FORMAT - + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', - + ' NOT COMPUTED.'/ - + ' (SEE INFO ABOVE.)') - 7500 FORMAT - + (/' BETA STATUS') - 8100 FORMAT - + (11X,I5,1P,D16.8) - 8200 FORMAT - + (3X,I5,' TO',I5,1P,7D16.8) - 8400 FORMAT - + (3X,I5,1X,1P,D16.8,3X,D12.4,3X,D16.8,1X,'TO',D16.8) - 8500 FORMAT - + (3X,I5,1X,1P,D16.8,6X,'ESTIMATED') - 8600 FORMAT - + (3X,I5,1X,1P,D16.8,6X,' FIXED') - 8700 FORMAT - + (3X,I5,1X,1P,D16.8,6X,' DROPPED') - 8800 FORMAT - + (/' N.B. NO PARAMETERS WERE FIXED BY THE USER OR', - + ' DROPPED AT THE LAST'/ - + ' ITERATION BECAUSE THEY CAUSED THE MODEL TO BE', - + ' RANK DEFICIENT.') - 8900 FORMAT - + (/' N.B. NO CHANGE WAS MADE TO THE USER SUPPLIED PARAMETER', - + ' VALUES BECAUSE'/ - + ' MAXIT=0.') - 9110 FORMAT - + ('(/'' I'',', - + I2,'('' DELTA(I,'',I1,'')'')/)') - 9120 FORMAT - + ('(/'' I'',', - + I2,'('' EPSILON(I,'',I1,'')''),', - + I2,'('' DELTA(I,'',I1,'')'')/)') - 9130 FORMAT - + ('(/'' I'',', - + I2,'('' EPSILON(I,'',I1,'')'')/)') - - END -*DODPCR - SUBROUTINE DODPCR - + (IPR,LUNRPT, - + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, - + N,M,NP,NQ,NPP,NNZW, - + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, - + WE,LDWE,LD2WE,WD,LDWD,LD2WD, - + IFIXB,IFIXX,LDIFX, - + SSF,TT,LDTT,STPB,STPD,LDSTPD, - + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, - + WSS,RVAR,IDF,SDBETA, - + NITER,NFEV,NJEV,ACTRED,PRERED, - + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) -C***BEGIN PROLOGUE DODPCR -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE GENERATE COMPUTATION REPORTS -C***END PROLOGUE DODPCR - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, - + SSTOL,TAU,TAUFAC - INTEGER - + IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE, - + LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV, - + NITER,NJEV,NNZW,NP,NPP,NQ - LOGICAL - + DIDVCV,FSTITR,HEAD,PRTPEN - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP),SSF(NP), - + STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), - + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1) - -C...LOCAL SCALARS - DOUBLE PRECISION - + PNLTY - LOGICAL - + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT - CHARACTER TYP*3 - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. -C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED -C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). -C BETA: THE FUNCTION PARAMETERS. -C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED -C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD -C DIFFERENCES (CDJAC=FALSE). -C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED -C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT -C (CHKJAC=FALSE). -C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS -C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). -C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS -C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). -C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. -C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST -C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). -C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE -C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). -C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF -C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE -C NUMBER OF PARAMETERS BEING ESTIMATED. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFLAG: THE VARIABLE DESIGNATING WHAT IS TO BE PRINTED. -C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY -C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO -C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M -C ELEMENTS OF ARRAY WORK (INITD=FALSE). -C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. -C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. -C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NITER: THE NUMBER OF ITERATIONS. -C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. -C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. -C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. -C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. -C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. -C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS -C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT -C (PRTPEN=FALSE). -C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. -C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO -C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX -C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). -C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART -C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). -C RVAR: THE RESIDUAL VARIANCE. -C SDBETA: THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S. -C SSF: THE SCALING VALUES FOR BETA. -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. -C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO BETA. -C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE -C DERIVATIVES WITH RESPECT TO DELTA. -C TAU: THE TRUST REGION DIAMETER. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C TT: THE SCALING VALUES FOR DELTA. -C TYP: THE CHARACTER*3 STRING "ODR" OR "OLS". -C WE: THE EPSILON WEIGHTS. -C WD: THE DELTA WEIGHTS. -C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, -C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND -C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. -C X: THE EXPLANATORY VARIABLE. -C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. - - -C***FIRST EXECUTABLE STATEMENT DODPCR - - - CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, - + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) - PNLTY = ABS(WE(1,1,1)) - - IF (HEAD) THEN - CALL DODPHD(HEAD,LUNRPT) - END IF - IF (ISODR) THEN - TYP = 'ODR' - ELSE - TYP = 'OLS' - END IF - -C PRINT INITIAL SUMMARY - - IF (IFLAG.EQ.1) THEN - WRITE (LUNRPT,1200) TYP - CALL DODPC1 - + (IPR,LUNRPT, - + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, - + MSGB(1),MSGB(2),MSGD(1),MSGD(2), - + N,M,NP,NQ,NPP,NNZW, - + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, - + Y,LDY,WE,LDWE,LD2WE,PNLTY, - + BETA,IFIXB,SSF,STPB, - + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, - + WSS(1),WSS(2),WSS(3)) - -C PRINT ITERATION REPORTS - - ELSE IF (IFLAG.EQ.2) THEN - - IF (FSTITR) THEN - WRITE (LUNRPT,1300) TYP - END IF - CALL DODPC2 - + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, - + PNLTY, - + NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) - -C PRINT FINAL SUMMARY - - ELSE IF (IFLAG.EQ.3) THEN - - WRITE (LUNRPT,1400) TYP - CALL DODPC3 - + (IPR,LUNRPT, - + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, - + N,M,NP,NQ,NPP, - + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, - + WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF, - + BETA,SDBETA,IFIXB,F,DELTA) - END IF - - RETURN - -C FORMAT STATEMENTS - - 1200 FORMAT - + (/' *** INITIAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') - 1300 FORMAT - + (/' *** ITERATION REPORTS FOR FIT BY METHOD OF ',A3, ' ***') - 1400 FORMAT - + (/' *** FINAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') - - END -*DODPE1 - SUBROUTINE DODPE1 - + (UNIT,D1,D2,D3,D4,D5, - + N,M,NQ, - + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, - + LWKMN,LIWKMN) -C***BEGIN PROLOGUE DODPE1 -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE PRINT ERROR REPORTS -C***END PROLOGUE DODPE1 - -C...SCALAR ARGUMENTS - INTEGER - + D1,D2,D3,D4,D5,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE, - + LIWKMN,LWKMN,M,N,NQ,UNIT - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. -C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. -C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. -C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. -C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. -C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. -C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. - - -C***FIRST EXECUTABLE STATEMENT DODPE1 - - -C PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION -C PARAMETERS - - IF (D1.EQ.1) THEN - IF (D2.NE.0) THEN - WRITE(UNIT,1100) - END IF - IF (D3.NE.0) THEN - WRITE(UNIT,1200) - END IF - IF (D4.NE.0) THEN - WRITE(UNIT,1300) - END IF - IF (D5.NE.0) THEN - WRITE(UNIT,1400) - END IF - -C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION -C PARAMETERS - - ELSE IF (D1.EQ.2) THEN - - IF (D2.NE.0) THEN - IF (D2.EQ.1 .OR. D2.EQ.3) THEN - WRITE(UNIT,2110) - END IF - IF (D2.EQ.2 .OR. D2.EQ.3) THEN - WRITE(UNIT,2120) - END IF - END IF - - IF (D3.NE.0) THEN - IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN - WRITE(UNIT,2210) - END IF - IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN - WRITE(UNIT,2220) - END IF - IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN - WRITE(UNIT,2230) - END IF - END IF - - IF (D4.NE.0) THEN - IF (D4.EQ.1 .OR. D4.EQ.3) THEN - WRITE(UNIT,2310) - END IF - IF (D4.EQ.2 .OR. D4.EQ.3) THEN - WRITE(UNIT,2320) - END IF - END IF - - IF (D5.NE.0) THEN - IF (D5.EQ.1 .OR. D5.EQ.3) THEN - WRITE(UNIT,2410) LWKMN - END IF - IF (D5.EQ.2 .OR. D5.EQ.3) THEN - WRITE(UNIT,2420) LIWKMN - END IF - END IF - - ELSE IF (D1.EQ.3) THEN - -C PRINT APPROPRIATE MESSAGES FOR ERRORS IN SCALE VALUES - - IF (D2.NE.0) THEN - IF (D2.EQ.1 .OR. D2.EQ.3) THEN - IF (LDSCLD.GE.N) THEN - WRITE(UNIT,3110) - ELSE - WRITE(UNIT,3120) - END IF - END IF - IF (D2.EQ.2 .OR. D2.EQ.3) THEN - WRITE(UNIT,3130) - END IF - END IF - -C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DERIVATIVE STEP VALUES - - IF (D3.NE.0) THEN - IF (D3.EQ.1 .OR. D3.EQ.3) THEN - IF (LDSTPD.GE.N) THEN - WRITE(UNIT,3210) - ELSE - WRITE(UNIT,3220) - END IF - END IF - IF (D3.EQ.2 .OR. D3.EQ.3) THEN - WRITE(UNIT,3230) - END IF - END IF - -C PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS - - IF (D4.NE.0) THEN - IF (D4.EQ.1) THEN - IF (LDWE.GE.N) THEN - IF (LD2WE.GE.NQ) THEN - WRITE(UNIT,3310) - ELSE - WRITE(UNIT,3320) - END IF - ELSE - IF (LD2WE.GE.NQ) THEN - WRITE(UNIT,3410) - ELSE - WRITE(UNIT,3420) - END IF - END IF - END IF - IF (D4.EQ.2) THEN - WRITE(UNIT,3500) - END IF - END IF - -C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS - - IF (D5.NE.0) THEN - IF (LDWD.GE.N) THEN - IF (LD2WD.GE.M) THEN - WRITE(UNIT,4310) - ELSE - WRITE(UNIT,4320) - END IF - ELSE - IF (LD2WD.GE.M) THEN - WRITE(UNIT,4410) - ELSE - WRITE(UNIT,4420) - END IF - END IF - END IF - - END IF - -C FORMAT STATEMENTS - - 1100 FORMAT - + (/' ERROR : N IS LESS THAN ONE.') - 1200 FORMAT - + (/' ERROR : M IS LESS THAN ONE.') - 1300 FORMAT - + (/' ERROR : NP IS LESS THAN ONE'/ - + ' OR NP IS GREATER THAN N.') - 1400 FORMAT - + (/' ERROR : NQ IS LESS THAN ONE.') - 2110 FORMAT - + (/' ERROR : LDX IS LESS THAN N.') - 2120 FORMAT - + (/' ERROR : LDY IS LESS THAN N.') - 2210 FORMAT - + (/' ERROR : LDIFX IS LESS THAN N'/ - + ' AND LDIFX IS NOT EQUAL TO ONE.') - 2220 FORMAT - + (/' ERROR : LDSCLD IS LESS THAN N'/ - + ' AND LDSCLD IS NOT EQUAL TO ONE.') - 2230 FORMAT - + (/' ERROR : LDSTPD IS LESS THAN N'/ - + ' AND LDSTPD IS NOT EQUAL TO ONE.') - 2310 FORMAT - + (/' ERROR : LDWE IS LESS THAN N'/ - + ' AND LDWE IS NOT EQUAL TO ONE OR'/ - + ' OR'/ - + ' LD2WE IS LESS THAN NQ'/ - + ' AND LD2WE IS NOT EQUAL TO ONE.') - 2320 FORMAT - + (/' ERROR : LDWD IS LESS THAN N'/ - + ' AND LDWD IS NOT EQUAL TO ONE.') - 2410 FORMAT - + (/' ERROR : LWORK IS LESS THAN ',I7, ','/ - + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.') - 2420 FORMAT - + (/' ERROR : LIWORK IS LESS THAN ',I7, ','/ - + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY', - + ' IWORK.') - 3110 FORMAT - + (/' ERROR : SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ - + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// - + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ - + ' AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/ - + ' EACH OF THE N BY M ELEMENTS OF'/ - + ' SCLD MUST BE GREATER THAN ZERO.') - 3120 FORMAT - + (/' ERROR : SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ - + ' FOR SOME J = 1, ..., M.'// - + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ - + ' AND LDSCLD IS EQUAL TO ONE THEN'/ - + ' EACH OF THE 1 BY M ELEMENTS OF'/ - + ' SCLD MUST BE GREATER THAN ZERO.') - 3130 FORMAT - + (/' ERROR : SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/ - + ' FOR SOME K = 1, ..., NP.'// - + ' ALL NP ELEMENTS OF', - + ' SCLB MUST BE GREATER THAN ZERO.') - 3210 FORMAT - + (/' ERROR : STPD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ - + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// - + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ - + ' AND LDSTPD IS GREATER THAN OR EQUAL TO N THEN'/ - + ' EACH OF THE N BY M ELEMENTS OF'/ - + ' STPD MUST BE GREATER THAN ZERO.') - 3220 FORMAT - + (/' ERROR : STPD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ - + ' FOR SOME J = 1, ..., M.'// - + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ - + ' AND LDSTPD IS EQUAL TO ONE THEN'/ - + ' EACH OF THE 1 BY M ELEMENTS OF'/ - + ' STPD MUST BE GREATER THAN ZERO.') - 3230 FORMAT - + (/' ERROR : STPB(K) IS LESS THAN OR EQUAL TO ZERO'/ - + ' FOR SOME K = 1, ..., NP.'// - + ' ALL NP ELEMENTS OF', - + ' STPB MUST BE GREATER THAN ZERO.') - 3310 FORMAT - + (/' ERROR : AT LEAST ONE OF THE (NQ BY NQ) ARRAYS STARTING'/ - + ' IN WE(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ - + ' SEMIDEFINITE. WHEN WE(1,1,1) IS GREATER THAN'/ - + ' OR EQUAL TO ZERO, AND LDWE IS GREATER THAN OR'/ - + ' EQUAL TO N, AND LD2WE IS GREATER THAN OR EQUAL'/ - + ' TO NQ, THEN EACH OF THE (NQ BY NQ) ARRAYS IN WE'/ - + ' MUST BE POSITIVE SEMIDEFINITE.') - 3320 FORMAT - + (/' ERROR : AT LEAST ONE OF THE (1 BY NQ) ARRAYS STARTING'/ - + ' IN WE(I,1,1), I = 1, ..., N, HAS A NEGATIVE'/ - + ' ELEMENT. WHEN WE(1,1,1) IS GREATER THAN OR'/ - + ' EQUAL TO ZERO, AND LDWE IS GREATER THAN OR EQUAL'/ - + ' TO N, AND LD2WE IS EQUAL TO 1, THEN EACH OF THE'/ - + ' (1 BY NQ) ARRAYS IN WE MUST HAVE ONLY NON-'/ - + ' NEGATIVE ELEMENTS.') - 3410 FORMAT - + (/' ERROR : THE (NQ BY NQ) ARRAY STARTING IN WE(1,1,1) IS'/ - + ' NOT POSITIVE SEMIDEFINITE. WHEN WE(1,1,1) IS'/ - + ' GREATER THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL'/ - + ' TO 1, AND LD2WE IS GREATER THAN OR EQUAL TO NQ,'/ - + ' THEN THE (NQ BY NQ) ARRAY IN WE MUST BE POSITIVE'/ - + ' SEMIDEFINITE.') - 3420 FORMAT - + (/' ERROR : THE (1 BY NQ) ARRAY STARTING IN WE(1,1,1) HAS'/ - + ' A NEGATIVE ELEMENT. WHEN WE(1,1,1) IS GREATER'/ - + ' THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL TO 1,'/ - + ' AND LD2WE IS EQUAL TO 1, THEN THE (1 BY NQ)'/ - + ' ARRAY IN WE MUST HAVE ONLY NONNEGATIVE ELEMENTS.') - 3500 FORMAT - + (/' ERROR : THE NUMBER OF NONZERO ARRAYS IN ARRAY WE IS'/ - + ' LESS THAN NP.') - 4310 FORMAT - + (/' ERROR : AT LEAST ONE OF THE (M BY M) ARRAYS STARTING'/ - + ' IN WD(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ - + ' DEFINITE. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ - + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ - + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN EACH'/ - + ' OF THE (M BY M) ARRAYS IN WD MUST BE POSITIVE'/ - + ' DEFINITE.') - 4320 FORMAT - + (/' ERROR : AT LEAST ONE OF THE (1 BY M) ARRAYS STARTING'/ - + ' IN WD(I,1,1), I = 1, ..., N, HAS A NONPOSITIVE'/ - + ' ELEMENT. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ - + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ - + ' LD2WD IS EQUAL TO 1, THEN EACH OF THE (1 BY M)'/ - + ' ARRAYS IN WD MUST HAVE ONLY POSITIVE ELEMENTS.') - 4410 FORMAT - + (/' ERROR : THE (M BY M) ARRAY STARTING IN WD(1,1,1) IS'/ - + ' NOT POSITIVE DEFINITE. WHEN WD(1,1,1) IS'/ - + ' GREATER THAN ZERO, AND LDWD IS EQUAL TO 1, AND'/ - + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN THE'/ - + ' (M BY M) ARRAY IN WD MUST BE POSITIVE DEFINITE.') - 4420 FORMAT - + (/' ERROR : THE (1 BY M) ARRAY STARTING IN WD(1,1,1) HAS A'/ - + ' NONPOSITIVE ELEMENT. WHEN WD(1,1,1) IS GREATER'/ - + ' THAN ZERO, AND LDWD IS EQUAL TO 1, AND LD2WD IS'/ - + ' EQUAL TO 1, THEN THE (1 BY M) ARRAY IN WD MUST'/ - + ' HAVE ONLY POSITIVE ELEMENTS.') - END -*DODPE2 - SUBROUTINE DODPE2 - + (UNIT, - + N,M,NP,NQ, - + FJACB,FJACD, - + DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD, - + XPLUSD,NROW,NETA,NTOL) -C***BEGIN PROLOGUE DODPE2 -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT -C***END PROLOGUE DODPE2 - -C...SCALAR ARGUMENTS - INTEGER - + M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT - LOGICAL - + ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) - INTEGER - + MSGB(NQ,NP),MSGD(NQ,M) - -C...LOCAL SCALARS - INTEGER - + I,J,K,L - CHARACTER FLAG*1,TYP*3 - -C...LOCAL ARRAYS - LOGICAL - + FTNOTE(0:7) - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND -C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C FLAG: THE CHARACTER STRING INDICATING HIGHLY QUESTIONABLE RESULTS. -C FTNOTE: THE ARRAY CONTROLLING FOOTNOTES. -C I: AN INDEX VARIABLE. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). -C J: AN INDEX VARIABLE. -C K: AN INDEX VARIABLE. -C L: AN INDEX VARIABLE. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. -C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. -C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. -C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT -C WHICH THE DERIVATIVE IS TO BE CHECKED. -C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE -C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. -C TYP: THE CHARACTER STRING INDICATING SOLUTION TYPE, ODR OR OLS. -C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. -C XPLUSD: THE VALUES OF X + DELTA. - - -C***FIRST EXECUTABLE STATEMENT DODPE2 - - -C SET UP FOR FOOTNOTES - - DO 10 I=0,7 - FTNOTE(I) = .FALSE. - 10 CONTINUE - - DO 40 L=1,NQ - IF (MSGB1.GE.1) THEN - DO 20 I=1,NP - IF (MSGB(L,I).GE.1) THEN - FTNOTE(0) = .TRUE. - FTNOTE(MSGB(L,I)) = .TRUE. - END IF - 20 CONTINUE - END IF - - IF (MSGD1.GE.1) THEN - DO 30 I=1,M - IF (MSGD(L,I).GE.1) THEN - FTNOTE(0) = .TRUE. - FTNOTE(MSGD(L,I)) = .TRUE. - END IF - 30 CONTINUE - END IF - 40 CONTINUE - -C PRINT REPORT - - IF (ISODR) THEN - TYP = 'ODR' - ELSE - TYP = 'OLS' - END IF - WRITE (UNIT,1000) TYP - - DO 70 L=1,NQ - - WRITE (UNIT,2100) L,NROW - WRITE (UNIT,2200) - - DO 50 I=1,NP - K = MSGB(L,I) - IF (K.GE.7) THEN - FLAG = '*' - ELSE - FLAG = ' ' - END IF - IF (K.LE.-1) THEN - WRITE (UNIT,3100) I - ELSE IF (K.EQ.0) THEN - WRITE (UNIT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG - ELSE IF (K.GE.1) THEN - WRITE (UNIT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K - END IF - 50 CONTINUE - IF (ISODR) THEN - DO 60 I=1,M - K = MSGD(L,I) - IF (K.GE.7) THEN - FLAG = '*' - ELSE - FLAG = ' ' - END IF - IF (K.LE.-1) THEN - WRITE (UNIT,4100) NROW,I - ELSE IF (K.EQ.0) THEN - WRITE (UNIT,4200) NROW,I, - + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG - ELSE IF (K.GE.1) THEN - WRITE (UNIT,4300) NROW,I, - + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K - END IF - 60 CONTINUE - END IF - 70 CONTINUE - -C PRINT FOOTNOTES - - IF (FTNOTE(0)) THEN - - WRITE (UNIT,5000) - IF (FTNOTE(1)) WRITE (UNIT,5100) - IF (FTNOTE(2)) WRITE (UNIT,5200) - IF (FTNOTE(3)) WRITE (UNIT,5300) - IF (FTNOTE(4)) WRITE (UNIT,5400) - IF (FTNOTE(5)) WRITE (UNIT,5500) - IF (FTNOTE(6)) WRITE (UNIT,5600) - IF (FTNOTE(7)) WRITE (UNIT,5700) - END IF - - IF (NETA.LT.0) THEN - WRITE (UNIT,6000) -NETA - ELSE - WRITE (UNIT,6100) NETA - END IF - WRITE (UNIT,7000) NTOL - -C PRINT OUT ROW OF EXPLANATORY VARIABLE WHICH WAS CHECKED. - - WRITE (UNIT,8100) NROW - - DO 80 J=1,M - WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) - 80 CONTINUE - - RETURN - -C FORMAT STATEMENTS - - 1000 FORMAT - + (//' *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3, - + ' ***'/) - 2100 FORMAT (/' FOR RESPONSE ',I2,' OF OBSERVATION ', I5/) - 2200 FORMAT (' ',' USER', - + ' ',' '/ - + ' ',' SUPPLIED', - + ' RELATIVE',' DERIVATIVE '/ - + ' DERIVATIVE WRT',' VALUE', - + ' DIFFERENCE',' ASSESSMENT '/) - 3100 FORMAT (' BETA(',I3,')', ' --- ', - + ' --- ',' UNCHECKED') - 3200 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, - + 'VERIFIED') - 3300 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, - + 'QUESTIONABLE (SEE NOTE ',I1,')') - 4100 FORMAT (' DELTA(',I2,',',I2,')', ' --- ', - + ' --- ',' UNCHECKED') - 4200 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, - + 'VERIFIED') - 4300 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, - + 'QUESTIONABLE (SEE NOTE ',I1,')') - 5000 FORMAT - + (/' NOTES:') - 5100 FORMAT - + (/' (1) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', - + ' AGREE, BUT'/ - + ' RESULTS ARE QUESTIONABLE BECAUSE BOTH ARE ZERO.') - 5200 FORMAT - + (/' (2) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', - + ' AGREE, BUT'/ - + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', - + ' IDENTICALLY ZERO'/ - + ' AND THE OTHER IS ONLY APPROXIMATELY ZERO.') - 5300 FORMAT - + (/' (3) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', - + ' DISAGREE, BUT'/ - + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', - + ' IDENTICALLY ZERO'/ - + ' AND THE OTHER IS NOT.') - 5400 FORMAT - + (/' (4) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', - + ' DISAGREE, BUT'/ - + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', - + ' BECAUSE EITHER'/ - + ' THE RATIO OF RELATIVE CURVATURE TO RELATIVE', - + ' SLOPE IS TOO HIGH'/ - + ' OR THE SCALE IS WRONG.') - 5500 FORMAT - + (/' (5) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', - + ' DISAGREE, BUT'/ - + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', - + ' BECAUSE THE'/ - + ' RATIO OF RELATIVE CURVATURE TO RELATIVE SLOPE IS', - + ' TOO HIGH.') - 5600 FORMAT - + (/' (6) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', - + ' DISAGREE, BUT'/ - + ' HAVE AT LEAST 2 DIGITS IN COMMON.') - 5700 FORMAT - + (/' (7) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', - + ' DISAGREE, AND'/ - + ' HAVE FEWER THAN 2 DIGITS IN COMMON. DERIVATIVE', - + ' CHECKING MUST'/ - + ' BE TURNED OFF IN ORDER TO PROCEED.') - 6000 FORMAT - + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', - + I5/ - + ' (ESTIMATED BY ODRPACK)') - 6100 FORMAT - + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', - + I5/ - + ' (SUPPLIED BY USER)') - 7000 FORMAT - + (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN '/ - + ' USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR '/ - + ' USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED ', - + I5) - 8100 FORMAT - + (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED ', - + I5// - + ' -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW'/) - 8110 FORMAT - + (10X,'X(',I2,',',I2,')',1X,1P,3D16.8) - END -*DODPE3 - SUBROUTINE DODPE3 - + (UNIT,D2,D3) -C***BEGIN PROLOGUE DODPE3 -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE PRINT ERROR REPORTS INDICATING THAT COMPUTATIONS WERE -C STOPPED IN USER SUPPLIED SUBROUTINES FCN -C***END PROLOGUE DODPE3 - -C...SCALAR ARGUMENTS - INTEGER - + D2,D3,UNIT - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. -C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. -C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. - - -C***FIRST EXECUTABLE STATEMENT DODPE3 - - -C PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE -C STOPPED - - IF (D2.EQ.2) THEN - WRITE(UNIT,1100) - ELSE IF (D2.EQ.3) THEN - WRITE(UNIT,1200) - ELSE IF (D2.EQ.4) THEN - WRITE(UNIT,1300) - END IF - IF (D3.EQ.2) THEN - WRITE(UNIT,1400) - END IF - -C FORMAT STATEMENTS - - 1100 FORMAT - + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ - + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED USING THE'/ - + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ - + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ - + ' PROPER EVALUATION OF SUBROUTINE FCN BEFORE THE '/ - + ' REGRESSION PROCEDURE CAN CONTINUE.') - 1200 FORMAT - + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ - + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ - + ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/ - + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, INDI-'/ - + ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/ - + ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION), '/ - + ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/ - + ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT '/ - + ' SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. THE '/ - + ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ - + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ - + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') - 1300 FORMAT - + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ - + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ - + ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT '/ - + ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/ - + ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR '/ - + ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS '/ - + ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA '/ - + ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN '/ - + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, '/ - + ' PREVENT SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. '/ - + ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ - + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ - + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') - 1400 FORMAT - + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ - + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED FOR '/ - + ' DERIVATIVE EVALUATIONS USING THE INITIAL ESTIMATES OF '/ - + ' BETA AND DELTA SUPPLIED BY THE USER. THE INITIAL '/ - + ' ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER EVALUATION '/ - + ' OF SUBROUTINE FCN BEFORE THE REGRESSION PROCEDURE CAN '/ - + ' CONTINUE.') - END -*DODPER - SUBROUTINE DODPER - + (INFO,LUNERR,SHORT, - + N,M,NP,NQ, - + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, - + LWKMN,LIWKMN, - + FJACB,FJACD, - + DIFF,MSGB,ISODR,MSGD, - + XPLUSD,NROW,NETA,NTOL) -C***BEGIN PROLOGUE DODPER -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DODPE1,DODPE2,DODPE3,DODPHD -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS -C***END PROLOGUE DODPER - -C...SCALAR ARGUMENTS - INTEGER - + INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN, - + M,N,NETA,NP,NQ,NROW,NTOL - LOGICAL - + ISODR,SHORT - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) - INTEGER - + MSGB(NQ*NP+1),MSGD(NQ*M+1) - -C...LOCAL SCALARS - INTEGER - + D1,D2,D3,D4,D5,UNIT - LOGICAL - + HEAD - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DODPE1,DODPE2,DODPE3,DODPHD - -C...INTRINSIC FUNCTIONS - INTRINSIC - + MOD - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. -C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. -C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. -C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. -C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. -C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND -C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE -C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). -C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. -C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. -C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. -C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. -C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. -C N: THE NUMBER OF OBSERVATIONS. -C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT -C WHICH THE DERIVATIVE IS TO BE CHECKED. -C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE -C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. -C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED -C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL -C (SHORT=.FALSE.). -C UNIT: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. -C XPLUSD: THE VALUES X + DELTA. - - -C***FIRST EXECUTABLE STATEMENT DODPER - - -C SET LOGICAL UNIT NUMBER FOR ERROR REPORT - - IF (LUNERR.EQ.0) THEN - RETURN - ELSE IF (LUNERR.LT.0) THEN - UNIT = 6 - ELSE - UNIT = LUNERR - END IF - -C PRINT HEADING - - HEAD = .TRUE. - CALL DODPHD(HEAD,UNIT) - -C EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO - - D1 = MOD(INFO,100000)/10000 - D2 = MOD(INFO,10000)/1000 - D3 = MOD(INFO,1000)/100 - D4 = MOD(INFO,100)/10 - D5 = MOD(INFO,10) - -C PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP - - IF (D1.GE.1 .AND. D1.LE.3) THEN - -C PRINT APPROPRIATE MESSAGES FOR ERRORS IN -C PROBLEM SPECIFICATION PARAMETERS -C DIMENSION SPECIFICATION PARAMETERS -C NUMBER OF GOOD DIGITS IN X -C WEIGHTS - - CALL DODPE1(UNIT,D1,D2,D3,D4,D5, - + N,M,NQ, - + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, - + LWKMN,LIWKMN) - - ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN - -C PRINT APPROPRIATE MESSAGES FOR DERIVATIVE CHECKING - - CALL DODPE2(UNIT, - + N,M,NP,NQ, - + FJACB,FJACD, - + DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2), - + XPLUSD,NROW,NETA,NTOL) - - ELSE IF (D1.EQ.5) THEN - -C PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FCN - - CALL DODPE3(UNIT,D2,D3) - - END IF - -C PRINT CORRECT FORM OF CALL STATEMENT - - IF ((D1.GE.1 .AND. D1.LE.3) .OR. - + (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. - + (D1.EQ.5)) THEN - IF (SHORT) THEN - WRITE (UNIT,1100) - ELSE - WRITE (UNIT,1200) - END IF - END IF - - RETURN - -C FORMAT STATEMENTS - - 1100 FORMAT - + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// - + ' CALL DODR'/ - + ' + (FCN,'/ - + ' + N,M,NP,NQ,'/ - + ' + BETA,'/ - + ' + Y,LDY,X,LDX,'/ - + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ - + ' + JOB,'/ - + ' + IPRINT,LUNERR,LUNRPT,'/ - + ' + WORK,LWORK,IWORK,LIWORK,'/ - + ' + INFO)') - 1200 FORMAT - + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// - + ' CALL DODRC'/ - + ' + (FCN,'/ - + ' + N,M,NP,NQ,'/ - + ' + BETA,'/ - + ' + Y,LDY,X,LDX,'/ - + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ - + ' + IFIXB,IFIXX,LDIFX,'/ - + ' + JOB,NDIGIT,TAUFAC,'/ - + ' + SSTOL,PARTOL,MAXIT,'/ - + ' + IPRINT,LUNERR,LUNRPT,'/ - + ' + STPB,STPD,LDSTPD,'/ - + ' + SCLB,SCLD,LDSCLD,'/ - + ' + WORK,LWORK,IWORK,LIWORK,'/ - + ' + INFO)') - - END -*DODPHD - SUBROUTINE DODPHD - + (HEAD,UNIT) -C***BEGIN PROLOGUE DODPHD -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE PRINT ODRPACK HEADING -C***END PROLOGUE DODPHD - -C...SCALAR ARGUMENTS - INTEGER - + UNIT - LOGICAL - + HEAD - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE -C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). -C UNIT: THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN. - - -C***FIRST EXECUTABLE STATEMENT DODPHD - - - IF (HEAD) THEN - WRITE(UNIT,1000) - HEAD = .FALSE. - END IF - - RETURN - -C FORMAT STATEMENTS - - 1000 FORMAT ( - + ' ******************************************************* '/ - + ' * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * '/ - + ' ******************************************************* '/) - END -*DODSTP - SUBROUTINE DODSTP - + (N,M,NP,NQ,NPP, - + F,FJACB,FJACD, - + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, - + ALPHA,EPSFCN,ISODR, - + TFJACB,OMEGA,U,QRAUX,KPVT, - + S,T,PHI,IRANK,RCOND,FORVCV, - + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) -C***BEGIN PROLOGUE DODSTP -C***REFER TO DODR,DODRC -C***ROUTINES CALLED IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2,DQRDC,DQRSL,DROT, -C DROTG,DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA) -C***END PROLOGUE DODSTP - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + ALPHA,EPSFCN,PHI,RCOND - INTEGER - + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ - LOGICAL - + ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), - + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), - + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), - + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK) - INTEGER - + KPVT(NP) - -C...LOCAL SCALARS - DOUBLE PRECISION - + CO,ONE,SI,TEMP,ZERO - INTEGER - + I,IMAX,INF,IPVT,J,K,K1,K2,KP,L - LOGICAL - + ELIM,FORVCV - -C...LOCAL ARRAYS - DOUBLE PRECISION - + DUM(2) - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DNRM2 - INTEGER - + IDAMAX - EXTERNAL - + DNRM2,IDAMAX - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG, - + DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,SQRT - -C...DATA STATEMENTS - DATA - + ZERO,ONE - + /0.0D0,1.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. -C CO: THE COSINE FROM THE PLANE ROTATION. -C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C DUM: A DUMMY ARRAY. -C ELIM: THE VARIABLE DESIGNATING WHETHER COLUMNS OF THE JACOBIAN -C WRT BETA HAVE BEEN ELIMINATED (ELIM=TRUE) OR NOT -C (ELIM=FALSE). -C EPSFCN: THE FUNCTION'S PRECISION. -C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS -C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS -C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). -C I: AN INDEXING VARIABLE. -C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE -C VALUE. -C INF: THE RETURN CODE FROM LINPACK ROUTINES. -C IPVT: THE VARIABLE DESIGNATING WHETHER PIVOTING IS TO BE DONE. -C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE -C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. -C J: AN INDEXING VARIABLE. -C K: AN INDEXING VARIABLE. -C K1: AN INDEXING VARIABLE. -C K2: AN INDEXING VARIABLE. -C KP: THE RANK OF THE JACOBIAN WRT BETA. -C KPVT: THE PIVOT VECTOR. -C L: AN INDEXING VARIABLE. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LWRK: THE LENGTH OF VECTOR WRK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C OMEGA: THE ARRAY DEFINED S.T. -C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) -C = (I-FJACD*INV(P)*TRANS(FJACD)) -C WHERE E = D**2 + ALPHA*TT**2 -C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 -C ONE: THE VALUE 1.0D0. -C PHI: THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP -C AND THE TRUST REGION DIAMETER. -C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE -C Q-R DECOMPOSITION. -C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. -C S: THE STEP FOR BETA. -C SI: THE SINE FROM THE PLANE ROTATION. -C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. -C T: THE STEP FOR DELTA. -C TEMP: A TEMPORARY STORAGE LOCATION. -C TFJACB: THE ARRAY OMEGA*FJACB. -C TT: THE SCALING VALUES FOR DELTA. -C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. -C WD: THE (SQUARED) DELTA WEIGHTS. -C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, -C EQUIVALENCED TO WRK1 AND WRK2. -C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK3: A WORK ARRAY OF (NP) ELEMENTS. -C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. -C WRK5: A WORK ARRAY OF (M) ELEMENTS. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODSTP - - -C COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE - -C SET UP KPVT IF ALPHA = 0 - - IF (ALPHA.EQ.ZERO) THEN - KP = NPP - DO 10 K=1,NP - KPVT(K) = K - 10 CONTINUE - ELSE - IF (NPP.GE.1) THEN - KP = NPP-IRANK - ELSE - KP = NPP - END IF - END IF - - IF (ISODR) THEN - -C T = WD * DELTA = D*G2 - CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,T,N) - - DO 300 I=1,N - -C COMPUTE WRK4, SUCH THAT -C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) - CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) - CALL DFCTR(.FALSE.,WRK4,M,M,INF) - IF (INF.NE.0) THEN - ISTOPC = 60000 - RETURN - END IF - -C COMPUTE OMEGA, SUCH THAT -C TRANS(OMEGA)*OMEGA = I+FJACD*INV(E)*TRANS(FJACD) -C INV(TRANS(OMEGA)*OMEGA) = I-FJACD*INV(P)*TRANS(FJACD) - CALL DVEVTR(M,NQ,I, - + FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5) - DO 110 L=1,NQ - OMEGA(L,L) = ONE + OMEGA(L,L) - 110 CONTINUE - CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF) - IF (INF.NE.0) THEN - ISTOPC = 60000 - RETURN - END IF - -C COMPUTE WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) -C = TRANS(FJACD)*INV(TRANS(OMEGA)*OMEGA) - DO 130 J=1,M - DO 120 L=1,NQ - WRK1(I,L,J) = FJACD(I,J,L) - 120 CONTINUE - CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4) - CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,2) - 130 CONTINUE - -C COMPUTE WRK5 = INV(E)*D*G2 - DO 140 J=1,M - WRK5(J) = T(I,J) - 140 CONTINUE - CALL DSOLVE(M,WRK4,M,WRK5,1,4) - CALL DSOLVE(M,WRK4,M,WRK5,1,2) - -C COMPUTE TFJACB = INV(TRANS(OMEGA))*FJACB - DO 170 K=1,KP - DO 150 L=1,NQ - TFJACB(I,L,K) = FJACB(I,KPVT(K),L) - 150 CONTINUE - CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1,K),N,4) - DO 160 L=1,NQ - IF (SS(1).GT.ZERO) THEN - TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) - ELSE - TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) - END IF - 160 CONTINUE - 170 CONTINUE - -C COMPUTE WRK2 = (V*INV(E)*D**2*G2 - G1) - DO 190 L=1,NQ - WRK2(I,L) = ZERO - DO 180 J=1,M - WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J) - 180 CONTINUE - WRK2(I,L) = WRK2(I,L) - F(I,L) - 190 CONTINUE - -C COMPUTE WRK2 = INV(TRANS(OMEGA))*(V*INV(E)*D**2*G2 - G1) - CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1),N,4) - 300 CONTINUE - - ELSE - DO 360 I=1,N - DO 350 L=1,NQ - DO 340 K=1,KP - TFJACB(I,L,K) = FJACB(I,KPVT(K),L) - IF (SS(1).GT.ZERO) THEN - TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) - ELSE - TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) - END IF - 340 CONTINUE - WRK2(I,L) = -F(I,L) - 350 CONTINUE - 360 CONTINUE - END IF - -C COMPUTE S - -C DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0) - - IF (ALPHA.EQ.ZERO) THEN - IPVT = 1 - DO 410 K=1,NP - KPVT(K) = 0 - 410 CONTINUE - ELSE - IPVT = 0 - END IF - - CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT) - CALL DQRSL(TFJACB,N*NQ,N*NQ,KP, - + QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF) - IF (INF.NE.0) THEN - ISTOPC = 60000 - RETURN - END IF - -C ELIMINATE ALPHA PART USING GIVENS ROTATIONS - - IF (ALPHA.NE.ZERO) THEN - CALL DZERO(NPP,1,S,NPP) - DO 430 K1=1,KP - CALL DZERO(KP,1,WRK3,KP) - WRK3(K1) = SQRT(ALPHA) - DO 420 K2=K1,KP - CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI) - IF (KP-K2.GE.1) THEN - CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ, - + WRK3(K2+1),1,CO,SI) - END IF - TEMP = CO*WRK2(K2,1) + SI*S(KPVT(K1)) - S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1)) - WRK2(K2,1) = TEMP - 420 CONTINUE - 430 CONTINUE - END IF - -C COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY - - IF (NPP.GE.1) THEN - IF (ALPHA.EQ.ZERO) THEN - KP = NPP - -C ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR - - 440 CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1) - IF (RCOND.LE.EPSFCN) THEN - ELIM = .TRUE. - IMAX = IDAMAX(KP,U,1) - -C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX KPVT - - IF (IMAX.NE.KP) THEN - CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1, - + QRAUX,WRK3,2) - K = KPVT(IMAX) - DO 450 I=IMAX,KP-1 - KPVT(I) = KPVT(I+1) - 450 CONTINUE - KPVT(KP) = K - END IF - KP = KP-1 - ELSE - ELIM = .FALSE. - END IF - IF (ELIM .AND. KP.GE.1) THEN - GO TO 440 - ELSE - IRANK = NPP-KP - END IF - END IF - END IF - - IF (FORVCV) RETURN - -C BACKSOLVE AND UNSCRAMBLE - - IF (NPP.GE.1) THEN - DO 510 I=KP+1,NPP - WRK2(I,1) = ZERO - 510 CONTINUE - IF (KP.GE.1) THEN - CALL DTRSL(TFJACB,N*NQ,KP,WRK2,01,INF) - IF (INF.NE.0) THEN - ISTOPC = 60000 - RETURN - END IF - END IF - DO 520 I=1,NPP - IF (SS(1).GT.ZERO) THEN - S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I)) - ELSE - S(KPVT(I)) = WRK2(I,1)/ABS(SS(1)) - END IF - 520 CONTINUE - END IF - - IF (ISODR) THEN - -C NOTE: T AND WRK1 HAVE BEEN INITIALIZED ABOVE, -C WHERE T = WD * DELTA = D*G2 -C WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) - - DO 670 I=1,N - -C COMPUTE WRK4, SUCH THAT -C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) - CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) - CALL DFCTR(.FALSE.,WRK4,M,M,INF) - IF (INF.NE.0) THEN - ISTOPC = 60000 - RETURN - END IF - -C COMPUTE WRK5 = INV(E)*D*G2 - DO 610 J=1,M - WRK5(J) = T(I,J) - 610 CONTINUE - CALL DSOLVE(M,WRK4,M,WRK5,1,4) - CALL DSOLVE(M,WRK4,M,WRK5,1,2) - - DO 640 L=1,NQ - WRK2(I,L) = F(I,L) - DO 620 K=1,NPP - WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K) - 620 CONTINUE - DO 630 J=1,M - WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J) - 630 CONTINUE - 640 CONTINUE - - DO 660 J=1,M - WRK5(J) = ZERO - DO 650 L=1,NQ - WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L) - 650 CONTINUE - T(I,J) = -(WRK5(J) + T(I,J)) - 660 CONTINUE - CALL DSOLVE(M,WRK4,M,T(I,1),N,4) - CALL DSOLVE(M,WRK4,M,T(I,1),N,2) - 670 CONTINUE - - END IF - -C COMPUTE PHI(ALPHA) FROM SCALED S AND T - - CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) - IF (ISODR) THEN - CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) - PHI = DNRM2(NPP+N*M,WRK,1) - ELSE - PHI = DNRM2(NPP,WRK,1) - END IF - - RETURN - END -*DODVCV - SUBROUTINE DODVCV - + (N,M,NP,NQ,NPP, - + F,FJACB,FJACD, - + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, - + EPSFCN,ISODR, - + VCV,SD, - + WRK6,OMEGA,U,QRAUX,JPVT, - + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, - + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) -C***BEGIN PROLOGUE DODVCV -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DPODI,DODSTP -C***DATE WRITTEN 901207 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS -C***END PROLOGUE DODVCV - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + EPSFCN,RCOND,RSS,RVAR - INTEGER - + IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ - LOGICAL - + ISODR - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + DELTA(N,M),F(N,NQ), - + FJACB(N,NP,NQ),FJACD(N,M,NQ), - + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP), - + T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M), - + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M), - + WRK6(N*NQ,NP),WRK(LWRK) - INTEGER - + IFIXB(NP),JPVT(NP) - -C...LOCAL SCALARS - DOUBLE PRECISION - + TEMP,ZERO - INTEGER - + I,IUNFIX,J,JUNFIX,KP,L - LOGICAL - + FORVCV - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DPODI,DODSTP - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,SQRT - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. -C EPSFCN: THE FUNCTION'S PRECISION. -C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. -C FJACB: THE JACOBIAN WITH RESPECT TO BETA. -C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. -C FORVCV: THE VARIABLE DESIGNATING WHETHER SUBROUTINE DODSTP IS -C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS -C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). -C I: AN INDEXING VARIABLE. -C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF -C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE -C NUMBER OF PARAMETERS BEING ESTIMATED. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE -C VALUE. -C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE -C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. -C IUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. -C J: AN INDEXING VARIABLE. -C JPVT: THE PIVOT VECTOR. -C JUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. -C KP: THE RANK OF THE JACOBIAN WRT BETA. -C L: AN INDEXING VARIABLE. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LWRK: THE LENGTH OF VECTOR WRK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C OMEGA: THE ARRAY DEFINED S.T. -C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) -C = (I-FJACD*INV(P)*TRANS(FJACD)) -C WHERE E = D**2 + ALPHA*TT**2 -C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 -C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE -C Q-R DECOMPOSITION. -C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. -C RSS: THE RESIDUAL SUM OF SQUARES. -C RVAR: THE RESIDUAL VARIANCE. -C S: THE STEP FOR BETA. -C SD: THE STANDARD DEVIATIONS OF THE ESTIMATED BETAS. -C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. -C SSF: THE SCALING VALUES USED FOR BETA. -C T: THE STEP FOR DELTA. -C TEMP: A TEMPORARY STORAGE LOCATION -C TT: THE SCALING VALUES FOR DELTA. -C U: THE APPROXIMATE NULL VECTOR FOR FJACB. -C VCV: THE COVARIANCE MATRIX OF THE ESTIMATED BETAS. -C WD: THE DELTA WEIGHTS. -C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, -C EQUIVALENCED TO WRK1 AND WRK2. -C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. -C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. -C WRK3: A WORK ARRAY OF (NP) ELEMENTS. -C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. -C WRK5: A WORK ARRAY OF (M) ELEMENTS. -C WRK6: A WORK ARRAY OF (N*NQ BY P) ELEMENTS. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODVCV - - - FORVCV = .TRUE. - ISTOPC = 0 - - CALL DODSTP(N,M,NP,NQ,NPP, - + F,FJACB,FJACD, - + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, - + ZERO,EPSFCN,ISODR, - + WRK6,OMEGA,U,QRAUX,JPVT, - + S,T,TEMP,IRANK,RCOND,FORVCV, - + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) - IF (ISTOPC.NE.0) THEN - RETURN - END IF - KP = NPP - IRANK - CALL DPODI (WRK6,N*NQ,KP,WRK3,1) - - IDF = 0 - DO 150 I=1,N - DO 120 J=1,NPP - DO 110 L=1,NQ - IF (FJACB(I,J,L).NE.ZERO) THEN - IDF = IDF + 1 - GO TO 150 - END IF - 110 CONTINUE - 120 CONTINUE - IF (ISODR) THEN - DO 140 J=1,M - DO 130 L=1,NQ - IF (FJACD(I,J,L).NE.ZERO) THEN - IDF = IDF + 1 - GO TO 150 - END IF - 130 CONTINUE - 140 CONTINUE - END IF - 150 CONTINUE - - IF (IDF.GT.KP) THEN - IDF = IDF - KP - RVAR = RSS/IDF - ELSE - IDF = 0 - RVAR = RSS - END IF - -C STORE VARIANCES IN SD, RESTORING ORIGINAL ORDER - - DO 200 I=1,NP - SD(I) = ZERO - 200 CONTINUE - DO 210 I=1,KP - SD(JPVT(I)) = WRK6(I,I) - 210 CONTINUE - IF (NP.GT.NPP) THEN - JUNFIX = NPP - DO 220 J=NP,1,-1 - IF (IFIXB(J).EQ.0) THEN - SD(J) = ZERO - ELSE - SD(J) = SD(JUNFIX) - JUNFIX = JUNFIX - 1 - END IF - 220 CONTINUE - END IF - -C STORE COVARIANCE MATRIX IN VCV, RESTORING ORIGINAL ORDER - - DO 310 I=1,NP - DO 300 J=1,I - VCV(I,J) = ZERO - 300 CONTINUE - 310 CONTINUE - DO 330 I=1,KP - DO 320 J=I+1,KP - IF (JPVT(I).GT.JPVT(J)) THEN - VCV(JPVT(I),JPVT(J))=WRK6(I,J) - ELSE - VCV(JPVT(J),JPVT(I))=WRK6(I,J) - END IF - 320 CONTINUE - 330 CONTINUE - IF (NP.GT.NPP) THEN - IUNFIX = NPP - DO 360 I=NP,1,-1 - IF (IFIXB(I).EQ.0) THEN - DO 340 J=I,1,-1 - VCV(I,J) = ZERO - 340 CONTINUE - ELSE - JUNFIX = NPP - DO 350 J=NP,1,-1 - IF (IFIXB(J).EQ.0) THEN - VCV(I,J) = ZERO - ELSE - VCV(I,J) = VCV(IUNFIX,JUNFIX) - JUNFIX = JUNFIX - 1 - END IF - 350 CONTINUE - IUNFIX = IUNFIX - 1 - END IF - 360 CONTINUE - END IF - - DO 380 I=1,NP - VCV(I,I) = SD(I) - SD(I) = SQRT(RVAR*SD(I)) - DO 370 J=1,I - VCV(J,I) = VCV(I,J) - 370 CONTINUE - 380 CONTINUE - -C UNSCALE STANDARD ERRORS AND COVARIANCE MATRIX - DO 410 I=1,NP - IF (SSF(1).GT.ZERO) THEN - SD(I) = SD(I)/SSF(I) - ELSE - SD(I) = SD(I)/ABS(SSF(1)) - END IF - DO 400 J=1,NP - IF (SSF(1).GT.ZERO) THEN - VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J)) - ELSE - VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1)) - END IF - 400 CONTINUE - 410 CONTINUE - - RETURN - END -*DPACK - SUBROUTINE DPACK - + (N2,N1,V1,V2,IFIX) -C***BEGIN PROLOGUE DPACK -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DCOPY -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1 -C***END PROLOGUE DPACK - -C...SCALAR ARGUMENTS - INTEGER - + N1,N2 - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + V1(N2),V2(N2) - INTEGER - + IFIX(N2) - -C...LOCAL SCALARS - INTEGER - + I - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DCOPY - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN INDEXING VARIABLE. -C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C N1: THE NUMBER OF ITEMS IN V1. -C N2: THE NUMBER OF ITEMS IN V2. -C V1: THE VECTOR OF THE UNFIXED ITEMS FROM V2. -C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE -C UNFIXED ELEMENTS ARE TO BE EXTRACTED. - - -C***FIRST EXECUTABLE STATEMENT DPACK - - - N1 = 0 - IF (IFIX(1).GE.0) THEN - DO 10 I=1,N2 - IF (IFIX(I).NE.0) THEN - N1 = N1+1 - V1(N1) = V2(I) - END IF - 10 CONTINUE - ELSE - N1 = N2 - CALL DCOPY(N2,V2,1,V1,1) - END IF - - RETURN - END -*DPPNML - DOUBLE PRECISION FUNCTION DPPNML - + (P) -C***BEGIN PROLOGUE DPPNML -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 901207 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***AUTHOR FILLIBEN, JAMES J., -C STATISTICAL ENGINEERING DIVISION -C NATIONAL BUREAU OF STANDARDS -C WASHINGTON, D. C. 20234 -C (ORIGINAL VERSION--JUNE 1972. -C (UPDATED --SEPTEMBER 1975, -C NOVEMBER 1975, AND -C OCTOBER 1976. -C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE -C NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN 0 AND STANDARD -C DEVIATION 1, AND WITH PROBABILITY DENSITY FUNCTION -C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). -C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS -C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) -C***DESCRIPTION -C --THE CODING AS PRESENTED BELOW IS ESSENTIALLY -C IDENTICAL TO THAT PRESENTED BY ODEH AND EVANS -C AS ALGORTIHM 70 OF APPLIED STATISTICS. -C --AS POINTED OUT BY ODEH AND EVANS IN APPLIED -C STATISTICS, THEIR ALGORITHM REPRESENTES A -C SUBSTANTIAL IMPROVEMENT OVER THE PREVIOUSLY EMPLOYED -C HASTINGS APPROXIMATION FOR THE NORMAL PERCENT POINT -C FUNCTION, WITH ACCURACY IMPROVING FROM 4.5*(10**-4) -C TO 1.5*(10**-8). -C***REFERENCES ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL -C DISTRIBUTION, ALGORTIHM 70, APPLIED STATISTICS, 1974, -C PAGES 96-97. -C EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND -C RATIONAL APPROXIMATION, M. SC. THESIS, 1972, -C UNIVERSITY OF VICTORIA, B. C., CANADA. -C HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, -C PAGES 113, 191, 192. -C NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS -C SERIES 55, 1964, PAGE 933, FORMULA 26.2.23. -C FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE -C LOCATION PARAMETER OF A SYMMETRIC DISTRIBUTION -C (UNPUBLISHED PH.D. DISSERTATION, PRINCETON -C UNIVERSITY), 1969, PAGES 21-44, 229-231. -C FILLIBEN, "THE PERCENT POINT FUNCTION", -C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. -C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, -C VOLUME 1, 1970, PAGES 40-111. -C KELLEY STATISTICAL TABLES, 1948. -C OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, PAGES 3-16. -C PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR -C STATISTICIANS, VOLUME 1, 1954, PAGES 104-113. -C***END PROLOGUE DPPNML - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + P - -C...LOCAL SCALARS - DOUBLE PRECISION - + ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO - -C...INTRINSIC FUNCTIONS - INTRINSIC - + LOG,SQRT - -C...DATA STATEMENTS - DATA - + P0,P1,P2,P3,P4 - + /-0.322232431088D0,-1.0D0,-0.342242088547D0, - + -0.204231210245D-1,-0.453642210148D-4/ - DATA - + Q0,Q1,Q2,Q3,Q4 - + /0.993484626060D-1,0.588581570495D0, - + 0.531103462366D0,0.103537752850D0,0.38560700634D-2/ - DATA - + ZERO,HALF,ONE,TWO - + /0.0D0,0.5D0,1.0D0,2.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ADEN: A VALUE USED IN THE APPROXIMATION. -C ANUM: A VALUE USED IN THE APPROXIMATION. -C HALF: THE VALUE 0.5D0. -C ONE: THE VALUE 1.0D0. -C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE -C EVALUATED. P MUST BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVE. -C P0: A PARAMETER USED IN THE APPROXIMATION. -C P1: A PARAMETER USED IN THE APPROXIMATION. -C P2: A PARAMETER USED IN THE APPROXIMATION. -C P3: A PARAMETER USED IN THE APPROXIMATION. -C P4: A PARAMETER USED IN THE APPROXIMATION. -C Q0: A PARAMETER USED IN THE APPROXIMATION. -C Q1: A PARAMETER USED IN THE APPROXIMATION. -C Q2: A PARAMETER USED IN THE APPROXIMATION. -C Q3: A PARAMETER USED IN THE APPROXIMATION. -C Q4: A PARAMETER USED IN THE APPROXIMATION. -C R: THE PROBABILITY AT WHICH THE PERCENT POINT IS EVALUATED. -C T: A VALUE USED IN THE APPROXIMATION. -C TWO: THE VALUE 2.0D0. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DPPT - - - IF (P.EQ.HALF) THEN - DPPNML = ZERO - - ELSE - R = P - IF (P.GT.HALF) R = ONE - R - T = SQRT(-TWO*LOG(R)) - ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0) - ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) - DPPNML = T + (ANUM/ADEN) - - IF (P.LT.HALF) DPPNML = -DPPNML - END IF - - RETURN - - END -*DPPT - DOUBLE PRECISION FUNCTION DPPT - + (P, IDF) -C***BEGIN PROLOGUE DPPT -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DPPNML -C***DATE WRITTEN 901207 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***AUTHOR FILLIBEN, JAMES J., -C STATISTICAL ENGINEERING DIVISION -C NATIONAL BUREAU OF STANDARDS -C WASHINGTON, D. C. 20234 -C (ORIGINAL VERSION--OCTOBER 1975.) -C (UPDATED --NOVEMBER 1975.) -C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE -C STUDENT'S T DISTRIBUTION WITH IDF DEGREES OF FREEDOM. -C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS -C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) -C***DESCRIPTION -C --FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION -C FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM -C AND SO THE COMPUTED PERCENT POINTS ARE EXACT. -C --FOR IDF BETWEEN 3 AND 6, INCLUSIVELY, THE APPROXIMATION -C IS AUGMENTED BY 3 ITERATIONS OF NEWTON'S METHOD TO -C IMPROVE THE ACCURACY, ESPECIALLY FOR P NEAR 0 OR 1. -C***REFERENCES NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS -C SERIES 55, 1964, PAGE 949, FORMULA 26.7.5. -C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, -C VOLUME 2, 1970, PAGE 102, FORMULA 11. -C FEDERIGHI, "EXTENDED TABLES OF THE PERCENTAGE POINTS -C OF STUDENT"S T DISTRIBUTION, JOURNAL OF THE AMERICAN -C STATISTICAL ASSOCIATION, 1969, PAGES 683-688. -C HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS, A -C HANDBOOK FOR STUDENTS AND PRACTITIONERS, 1975, -C PAGES 120-123. -C***END PROLOGUE DPPT - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + P - INTEGER - + IDF - -C...LOCAL SCALARS - DOUBLE PRECISION - + ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45, - + B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN, - + HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO, - + Z,ZERO - INTEGER - + IPASS,MAXIT - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DPPNML - EXTERNAL - + DPPNML - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ATAN,COS,SIN,SQRT - -C...DATA STATEMENTS - DATA - + B21 - + /4.0D0/ - DATA - + B31, B32, B33, B34 - + /96.0D0,5.0D0,16.0D0,3.0D0/ - DATA - + B41, B42, B43, B44, B45 - + /384.0D0,3.0D0,19.0D0,17.0D0,-15.0D0/ - DATA - + B51,B52,B53,B54,B55,B56 - + /9216.0D0,79.0D0,776.0D0,1482.0D0,-1920.0D0,-945.0D0/ - DATA - + ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN - + /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,8.0D0,15.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ARG: A VALUE USED IN THE APPROXIMATION. -C B21: A PARAMETER USED IN THE APPROXIMATION. -C B31: A PARAMETER USED IN THE APPROXIMATION. -C B32: A PARAMETER USED IN THE APPROXIMATION. -C B33: A PARAMETER USED IN THE APPROXIMATION. -C B34: A PARAMETER USED IN THE APPROXIMATION. -C B41: A PARAMETER USED IN THE APPROXIMATION. -C B42: A PARAMETER USED IN THE APPROXIMATION. -C B43: A PARAMETER USED IN THE APPROXIMATION. -C B44: A PARAMETER USED IN THE APPROXIMATION. -C B45: A PARAMETER USED IN THE APPROXIMATION. -C B51: A PARAMETER USED IN THE APPROXIMATION. -C B52: A PARAMETER USED IN THE APPROXIMATION. -C B53: A PARAMETER USED IN THE APPROXIMATION. -C B54: A PARAMETER USED IN THE APPROXIMATION. -C B55: A PARAMETER USED IN THE APPROXIMATION. -C B56: A PARAMETER USED IN THE APPROXIMATION. -C C: A VALUE USED IN THE APPROXIMATION. -C CON: A VALUE USED IN THE APPROXIMATION. -C DF: THE DEGREES OF FREEDOM. -C D1: A VALUE USED IN THE APPROXIMATION. -C D3: A VALUE USED IN THE APPROXIMATION. -C D5: A VALUE USED IN THE APPROXIMATION. -C D7: A VALUE USED IN THE APPROXIMATION. -C D9: A VALUE USED IN THE APPROXIMATION. -C EIGHT: THE VALUE 8.0D0. -C FIFTN: THE VALUE 15.0D0. -C HALF: THE VALUE 0.5D0. -C IDF: THE (POSITIVE INTEGER) DEGREES OF FREEDOM. -C IPASS: A VALUE USED IN THE APPROXIMATION. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR THE APPROX. -C ONE: THE VALUE 1.0D0. -C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE -C EVALUATED. P MUST LIE BETWEEN 0.0DO AND 1.0D0, EXCLUSIVE. -C PI: THE VALUE OF PI. -C PPFN: THE NORMAL PERCENT POINT VALUE. -C S: A VALUE USED IN THE APPROXIMATION. -C TERM1: A VALUE USED IN THE APPROXIMATION. -C TERM2: A VALUE USED IN THE APPROXIMATION. -C TERM3: A VALUE USED IN THE APPROXIMATION. -C TERM4: A VALUE USED IN THE APPROXIMATION. -C TERM5: A VALUE USED IN THE APPROXIMATION. -C THREE: THE VALUE 3.0D0. -C TWO: THE VALUE 2.0D0. -C Z: A VALUE USED IN THE APPROXIMATION. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DPPT - - - PI = 3.141592653589793238462643383279D0 - DF = IDF - MAXIT = 5 - - IF (IDF.LE.0) THEN - -C TREAT THE IDF < 1 CASE - DPPT = ZERO - - ELSE IF (IDF.EQ.1) THEN - -C TREAT THE IDF = 1 (CAUCHY) CASE - ARG = PI*P - DPPT = -COS(ARG)/SIN(ARG) - - ELSE IF (IDF.EQ.2) THEN - -C TREAT THE IDF = 2 CASE - TERM1 = SQRT(TWO)/TWO - TERM2 = TWO*P - ONE - TERM3 = SQRT(P*(ONE-P)) - DPPT = TERM1*TERM2/TERM3 - - ELSE IF (IDF.GE.3) THEN - -C TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE - PPFN = DPPNML(P) - D1 = PPFN - D3 = PPFN**3 - D5 = PPFN**5 - D7 = PPFN**7 - D9 = PPFN**9 - TERM1 = D1 - TERM2 = (ONE/B21)*(D3+D1)/DF - TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) - TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) - TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4) - DPPT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5 - - IF (IDF.EQ.3) THEN - -C AUGMENT THE RESULTS FOR THE IDF = 3 CASE - CON = PI*(P-HALF) - ARG = DPPT/SQRT(DF) - Z = ATAN(ARG) - DO 70 IPASS=1,MAXIT - S = SIN(Z) - C = COS(Z) - Z = Z - (Z+S*C-CON)/(TWO*C**2) - 70 CONTINUE - DPPT = SQRT(DF)*S/C - - ELSE IF (IDF.EQ.4) THEN - -C AUGMENT THE RESULTS FOR THE IDF = 4 CASE - CON = TWO*(P-HALF) - ARG = DPPT/SQRT(DF) - Z = ATAN(ARG) - DO 90 IPASS=1,MAXIT - S = SIN(Z) - C = COS(Z) - Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3) - 90 CONTINUE - DPPT = SQRT(DF)*S/C - - ELSE IF (IDF.EQ.5) THEN - -C AUGMENT THE RESULTS FOR THE IDF = 5 CASE - - CON = PI*(P-HALF) - ARG = DPPT/SQRT(DF) - Z = ATAN(ARG) - DO 110 IPASS=1,MAXIT - S = SIN(Z) - C = COS(Z) - Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/ - + ((EIGHT/THREE)*C**4) - 110 CONTINUE - DPPT = SQRT(DF)*S/C - - ELSE IF (IDF.EQ.6) THEN - -C AUGMENT THE RESULTS FOR THE IDF = 6 CASE - CON = TWO*(P-HALF) - ARG = DPPT/SQRT(DF) - Z = ATAN(ARG) - DO 130 IPASS=1,MAXIT - S = SIN(Z) - C = COS(Z) - Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/ - + ((FIFTN/EIGHT)*C**5) - 130 CONTINUE - DPPT = SQRT(DF)*S/C - END IF - END IF - - RETURN - - END -*DPVB - SUBROUTINE DPVB - + (FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STP, - + ISTOP,NFEV,PVB, - + WRK1,WRK2,WRK6) -C***BEGIN PROLOGUE DPVB -C***REFER TO DODR,DODRC -C***ROUTINES CALLED FCN -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP -C***END PROLOGUE DPVB - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + PVB,STP - INTEGER - + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + BETAJ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C BETAJ: THE CURRENT ESTIMATE OF THE JTH PARAMETER. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT -C WHICH THE DERIVATIVE IS TO BE CHECKED. -C PVB: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. -C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. -C XPLUSD: THE VALUES OF X + DELTA. - - -C***FIRST EXECUTABLE STATEMENT DPVB - - -C COMPUTE PREDICTED VALUES - - BETAJ = BETA(J) - BETA(J) = BETA(J) + STP - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 003,WRK2,WRK6,WRK1, - + ISTOP) - IF (ISTOP.EQ.0) THEN - NFEV = NFEV + 1 - ELSE - RETURN - END IF - BETA(J) = BETAJ - - PVB = WRK2(NROW,LQ) - - RETURN - END -*DPVD - SUBROUTINE DPVD - + (FCN, - + N,M,NP,NQ, - + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, - + NROW,J,LQ,STP, - + ISTOP,NFEV,PVD, - + WRK1,WRK2,WRK6) -C***BEGIN PROLOGUE DPVD -C***REFER TO DODR,DODRC -C***ROUTINES CALLED FCN -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE COMPUTE NROW-TH FUNCTION VALUE USING -C X(NROW,J) + DELTA(NROW,J) + STP -C***END PROLOGUE DPVD - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + PVD,STP - INTEGER - + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M) - -C...SUBROUTINE ARGUMENTS - EXTERNAL - + FCN - -C...LOCAL SCALARS - DOUBLE PRECISION - + XPDJ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS -C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. -C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT -C WHICH THE DERIVATIVE IS TO BE CHECKED. -C PVD: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. -C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. -C XPDJ: THE (NROW,J)TH ELEMENT OF XPLUSD. -C XPLUSD: THE VALUES OF X + DELTA. - - -C***FIRST EXECUTABLE STATEMENT DPVD - - -C COMPUTE PREDICTED VALUES - - XPDJ = XPLUSD(NROW,J) - XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP - ISTOP = 0 - CALL FCN(N,M,NP,NQ, - + N,M,NP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + 003,WRK2,WRK6,WRK1, - + ISTOP) - IF (ISTOP.EQ.0) THEN - NFEV = NFEV + 1 - ELSE - RETURN - END IF - XPLUSD(NROW,J) = XPDJ - - PVD = WRK2(NROW,LQ) - - RETURN - END -*DSCALE - SUBROUTINE DSCALE - + (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT) -C***BEGIN PROLOGUE DSCALE -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SCALE T BY THE INVERSE OF SCL, I.E., COMPUTE T/SCL -C***END PROLOGUE DSCALE - -C...SCALAR ARGUMENTS - INTEGER - + LDT,LDSCL,LDSCLT,M,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M) - -C...LOCAL SCALARS - DOUBLE PRECISION - + ONE,TEMP,ZERO - INTEGER - + I,J - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS - -C...DATA STATEMENTS - DATA - + ONE,ZERO - + /1.0D0,0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN INDEXING VARIABLE. -C J: AN INDEXING VARIABLE. -C LDSCL: THE LEADING DIMENSION OF ARRAY SCL. -C LDSCLT: THE LEADING DIMENSION OF ARRAY SCLT. -C LDT: THE LEADING DIMENSION OF ARRAY T. -C M: THE NUMBER OF COLUMNS OF DATA IN T. -C N: THE NUMBER OF ROWS OF DATA IN T. -C ONE: THE VALUE 1.0D0. -C SCL: THE SCALE VALUES. -C SCLT: THE INVERSELY SCALED MATRIX. -C T: THE ARRAY TO BE INVERSELY SCALED BY SCL. -C TEMP: A TEMPORARY SCALAR. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DSCALE - - - IF (N.EQ.0 .OR. M.EQ.0) RETURN - - IF (SCL(1,1).GE.ZERO) THEN - IF (LDSCL.GE.N) THEN - DO 80 J=1,M - DO 70 I=1,N - SCLT(I,J) = T(I,J)/SCL(I,J) - 70 CONTINUE - 80 CONTINUE - ELSE - DO 100 J=1,M - TEMP = ONE/SCL(1,J) - DO 90 I=1,N - SCLT(I,J) = T(I,J)*TEMP - 90 CONTINUE - 100 CONTINUE - END IF - ELSE - TEMP = ONE/ABS(SCL(1,1)) - DO 120 J=1,M - DO 110 I=1,N - SCLT(I,J) = T(I,J)*TEMP - 110 CONTINUE - 120 CONTINUE - END IF - - RETURN - END -*DSCLB - SUBROUTINE DSCLB - + (NP,BETA,SSF) -C***BEGIN PROLOGUE DSCLB -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SELECT SCALING VALUES FOR BETA ACCORDING TO THE -C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE -C***END PROLOGUE DSCLB - -C...SCALAR ARGUMENTS - INTEGER - + NP - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),SSF(NP) - -C...LOCAL SCALARS - DOUBLE PRECISION - + BMAX,BMIN,ONE,TEN,ZERO - INTEGER - + K - LOGICAL - + BIGDIF - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,LOG10,MAX,MIN,SQRT - -C...DATA STATEMENTS - DATA - + ZERO,ONE,TEN - + /0.0D0,1.0D0,10.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT -C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF -C BETA (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). -C BMAX: THE LARGEST NONZERO MAGNITUDE. -C BMIN: THE SMALLEST NONZERO MAGNITUDE. -C K: AN INDEXING VARIABLE. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C ONE: THE VALUE 1.0D0. -C SSF: THE SCALING VALUES FOR BETA. -C TEN: THE VALUE 10.0D0. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DSCLB - - - BMAX = ABS(BETA(1)) - DO 10 K=2,NP - BMAX = MAX(BMAX,ABS(BETA(K))) - 10 CONTINUE - - IF (BMAX.EQ.ZERO) THEN - -C ALL INPUT VALUES OF BETA ARE ZERO - - DO 20 K=1,NP - SSF(K) = ONE - 20 CONTINUE - - ELSE - -C SOME OF THE INPUT VALUES ARE NONZERO - - BMIN = BMAX - DO 30 K=1,NP - IF (BETA(K).NE.ZERO) THEN - BMIN = MIN(BMIN,ABS(BETA(K))) - END IF - 30 CONTINUE - BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE - DO 40 K=1,NP - IF (BETA(K).EQ.ZERO) THEN - SSF(K) = TEN/BMIN - ELSE - IF (BIGDIF) THEN - SSF(K) = ONE/ABS(BETA(K)) - ELSE - SSF(K) = ONE/BMAX - END IF - END IF - 40 CONTINUE - - END IF - - RETURN - END -*DSCLD - SUBROUTINE DSCLD - + (N,M,X,LDX,TT,LDTT) -C***BEGIN PROLOGUE DSCLD -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SELECT SCALING VALUES FOR DELTA ACCORDING TO THE -C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE -C***END PROLOGUE DSCLD - -C...SCALAR ARGUMENTS - INTEGER - + LDTT,LDX,M,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + TT(LDTT,M),X(LDX,M) - -C...LOCAL SCALARS - DOUBLE PRECISION - + ONE,TEN,XMAX,XMIN,ZERO - INTEGER - + I,J - LOGICAL - + BIGDIF - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,LOG10,MAX,MIN - -C...DATA STATEMENTS - DATA - + ZERO,ONE,TEN - + /0.0D0,1.0D0,10.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT -C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF -C X (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). -C I: AN INDEXING VARIABLE. -C J: AN INDEXING VARIABLE. -C LDTT: THE LEADING DIMENSION OF ARRAY TT. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C ONE: THE VALUE 1.0D0. -C TT: THE SCALING VALUES FOR DELTA. -C X: THE INDEPENDENT VARIABLE. -C XMAX: THE LARGEST NONZERO MAGNITUDE. -C XMIN: THE SMALLEST NONZERO MAGNITUDE. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DSCLD - - - DO 50 J=1,M - XMAX = ABS(X(1,J)) - DO 10 I=2,N - XMAX = MAX(XMAX,ABS(X(I,J))) - 10 CONTINUE - - IF (XMAX.EQ.ZERO) THEN - -C ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO - - DO 20 I=1,N - TT(I,J) = ONE - 20 CONTINUE - - ELSE - -C SOME OF THE INPUT VALUES ARE NONZERO - - XMIN = XMAX - DO 30 I=1,N - IF (X(I,J).NE.ZERO) THEN - XMIN = MIN(XMIN,ABS(X(I,J))) - END IF - 30 CONTINUE - BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE - DO 40 I=1,N - IF (X(I,J).NE.ZERO) THEN - IF (BIGDIF) THEN - TT(I,J) = ONE/ABS(X(I,J)) - ELSE - TT(I,J) = ONE/XMAX - END IF - ELSE - TT(I,J) = TEN/XMIN - END IF - 40 CONTINUE - END IF - 50 CONTINUE - - RETURN - END -*DSETN - SUBROUTINE DSETN - + (N,M,X,LDX,NROW) -C***BEGIN PROLOGUE DSETN -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED -C***END PROLOGUE DSETN - -C...SCALAR ARGUMENTS - INTEGER - + LDX,M,N,NROW - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + X(LDX,M) - -C...LOCAL SCALARS - INTEGER - + I,J - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN INDEX VARIABLE. -C J: AN INDEX VARIABLE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NROW: THE SELECTED ROW NUMBER OF THE INDEPENDENT VARIABLE. -C X: THE INDEPENDENT VARIABLE. - - -C***FIRST EXECUTABLE STATEMENT DSETN - - - IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN - -C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS -C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. - - DO 20 I = 1, N - DO 10 J = 1, M - IF (X(I,J).EQ.0.0) GO TO 20 - 10 CONTINUE - NROW = I - RETURN - 20 CONTINUE - - NROW = 1 - - RETURN - END -*DSOLVE - SUBROUTINE DSOLVE(N,T,LDT,B,LDB,JOB) -C***BEGIN PROLOGUE DSOLVE -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DAXPY,DDOT -C***DATE WRITTEN 920220 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE SOLVE SYSTEMS OF THE FORM -C T * X = B OR TRANS(T) * X = B -C WHERE T IS AN UPPER OR LOWER TRIANGULAR MATRIX OF ORDER N, -C AND THE SOLUTION X OVERWRITES THE RHS B. -C (ADAPTED FROM LINPACK SUBROUTINE DTRSL) -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***END PROLOGUE DSOLVE - -C...SCALAR ARGUMENTS - INTEGER - + JOB,LDB,LDT,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + B(LDB,N),T(LDT,N) - -C...LOCAL SCALARS - DOUBLE PRECISION - + TEMP,ZERO - INTEGER - + J1,J,JN - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DDOT - EXTERNAL - + DDOT - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DAXPY - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C B: ON INPUT: THE RIGHT HAND SIDE; ON EXIT: THE SOLUTION -C J1: THE FIRST NONZERO ENTRY IN T. -C J: AN INDEXING VARIABLE. -C JN: THE LAST NONZERO ENTRY IN T. -C JOB: WHAT KIND OF SYSTEM IS TO BE SOLVED, WHERE IF JOB IS -C 1 SOLVE T*X=B, T LOWER TRIANGULAR, -C 2 SOLVE T*X=B, T UPPER TRIANGULAR, -C 3 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, -C 4 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. -C LDB: THE LEADING DIMENSION OF ARRAY B. -C LDT: THE LEADING DIMENSION OF ARRAY T. -C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY T. -C T: THE UPPER OR LOWER TRIDIAGONAL SYSTEM. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DSOLVE - - -C FIND FIRST NONZERO DIAGONAL ENTRY IN T - J1 = 0 - DO 10 J=1,N - IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN - J1 = J - ELSE IF (T(J,J).EQ.ZERO) THEN - B(1,J) = ZERO - END IF - 10 CONTINUE - IF (J1.EQ.0) RETURN - -C FIND LAST NONZERO DIAGONAL ENTRY IN T - JN = 0 - DO 20 J=N,J1,-1 - IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN - JN = J - ELSE IF (T(J,J).EQ.ZERO) THEN - B(1,J) = ZERO - END IF - 20 CONTINUE - - IF (JOB.EQ.1) THEN - -C SOLVE T*X=B FOR T LOWER TRIANGULAR - B(1,J1) = B(1,J1)/T(J1,J1) - DO 30 J = J1+1, JN - TEMP = -B(1,J-1) - CALL DAXPY(JN-J+1,TEMP,T(J,J-1),1,B(1,J),LDB) - IF (T(J,J).NE.ZERO) THEN - B(1,J) = B(1,J)/T(J,J) - ELSE - B(1,J) = ZERO - END IF - 30 CONTINUE - - ELSE IF (JOB.EQ.2) THEN - -C SOLVE T*X=B FOR T UPPER TRIANGULAR. - B(1,JN) = B(1,JN)/T(JN,JN) - DO 40 J = JN-1,J1,-1 - TEMP = -B(1,J+1) - CALL DAXPY(J,TEMP,T(1,J+1),1,B(1,1),LDB) - IF (T(J,J).NE.ZERO) THEN - B(1,J) = B(1,J)/T(J,J) - ELSE - B(1,J) = ZERO - END IF - 40 CONTINUE - - ELSE IF (JOB.EQ.3) THEN - -C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. - B(1,JN) = B(1,JN)/T(JN,JN) - DO 50 J = JN-1,J1,-1 - B(1,J) = B(1,J) - DDOT(JN-J+1,T(J+1,J),1,B(1,J+1),LDB) - IF (T(J,J).NE.ZERO) THEN - B(1,J) = B(1,J)/T(J,J) - ELSE - B(1,J) = ZERO - END IF - 50 CONTINUE - - ELSE IF (JOB.EQ.4) THEN - -C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. - B(1,J1) = B(1,J1)/T(J1,J1) - DO 60 J = J1+1,JN - B(1,J) = B(1,J) - DDOT(J-1,T(1,J),1,B(1,1),LDB) - IF (T(J,J).NE.ZERO) THEN - B(1,J) = B(1,J)/T(J,J) - ELSE - B(1,J) = ZERO - END IF - 60 CONTINUE - END IF - - RETURN - END -*DUNPAC - SUBROUTINE DUNPAC - + (N2,V1,V2,IFIX) -C***BEGIN PROLOGUE DUNPAC -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DCOPY -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE -C UNFIXED -C***END PROLOGUE DUNPAC - -C...SCALAR ARGUMENTS - INTEGER - + N2 - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + V1(N2),V2(N2) - INTEGER - + IFIX(N2) - -C...LOCAL SCALARS - INTEGER - + I,N1 - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DCOPY - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN INDEXING VARIABLE. -C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C ODRPACK REFERENCE GUIDE.) -C N1: THE NUMBER OF ITEMS IN V1. -C N2: THE NUMBER OF ITEMS IN V2. -C V1: THE VECTOR OF THE UNFIXED ITEMS. -C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE -C ELEMENTS OF V1 ARE TO BE INSERTED. - - -C***FIRST EXECUTABLE STATEMENT DUNPAC - - - N1 = 0 - IF (IFIX(1).GE.0) THEN - DO 10 I = 1,N2 - IF (IFIX(I).NE.0) THEN - N1 = N1 + 1 - V2(I) = V1(N1) - END IF - 10 CONTINUE - ELSE - N1 = N2 - CALL DCOPY(N2,V1,1,V2,1) - END IF - - RETURN - END -*DVEVTR - SUBROUTINE DVEVTR - + (M,NQ,INDX, - + V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV, - + WRK5) -C***BEGIN PROLOGUE DVEVTR -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DSOLVE -C***DATE WRITTEN 910613 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE COMPUTE V*E*TRANS(V) FOR THE (INDX)TH M BY NQ ARRAY IN V -C***END PROLOGUE DVEVTR - -C...SCALAR ARGUMENTS - INTEGER - + INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M) - -C...LOCAL SCALARS - DOUBLE PRECISION - + ZERO - INTEGER - + J,L1,L2 - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DSOLVE - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C INDX: THE ROW IN V IN WHICH THE M BY NQ ARRAY IS STORED. -C J: AN INDEXING VARIABLE. -C LDE: THE LEADING DIMENSION OF ARRAY E. -C LDV: THE LEADING DIMENSION OF ARRAY V. -C LDVE: THE LEADING DIMENSION OF ARRAY VE. -C LDVEV: THE LEADING DIMENSION OF ARRAY VEV. -C LD2V: THE SECOND DIMENSION OF ARRAY V. -C L1: AN INDEXING VARIABLE. -C L2: AN INDEXING VARIABLE. -C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C E: THE M BY M MATRIX OF THE FACTORS SO ETE = (D**2 + ALPHA*T**2). -C V: AN ARRAY OF NQ BY M MATRICES. -C VE: THE NQ BY M ARRAY VE = V * INV(E) -C VEV: THE NQ BY NQ ARRAY VEV = V * INV(ETE) * TRANS(V). -C WRK5: AN M WORK VECTOR. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DVEVTR - - - IF (NQ.EQ.0 .OR. M.EQ.0) RETURN - - DO 140 L1 = 1,NQ - DO 110 J = 1,M - WRK5(J) = V(INDX,J,L1) - 110 CONTINUE - CALL DSOLVE(M,E,LDE,WRK5,1,4) - DO 120 J = 1,M - VE(INDX,L1,J) = WRK5(J) - 120 CONTINUE - 140 CONTINUE - - DO 230 L1 = 1,NQ - DO 220 L2 = 1,L1 - VEV(L1,L2) = ZERO - DO 210 J = 1,M - VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J) - 210 CONTINUE - VEV(L2,L1) = VEV(L1,L2) - 220 CONTINUE - 230 CONTINUE - - RETURN - END -*DWGHT - SUBROUTINE DWGHT - + (N,M,WT,LDWT,LD2WT,T,LDT,WTT,LDWTT) -C***BEGIN PROLOGUE DWGHT -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SCALE MATRIX T USING WT, I.E., COMPUTE WTT = WT*T -C***END PROLOGUE DWGHT - -C...SCALAR ARGUMENTS - INTEGER - + LDT,LDWT,LDWTT,LD2WT,M,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + T(LDT,M),WT(LDWT,LD2WT,M),WTT(LDWTT,M) - -C...LOCAL SCALARS - DOUBLE PRECISION - + TEMP,ZERO - INTEGER - + I,J,K - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN INDEXING VARIABLE. -C J: AN INDEXING VARIABLE. -C K: AN INDEXING VARIABLE. -C LDT: THE LEADING DIMENSION OF ARRAY T. -C LDWT: THE LEADING DIMENSION OF ARRAY WT. -C LDWTT: THE LEADING DIMENSION OF ARRAY WTT. -C LD2WT: THE SECOND DIMENSION OF ARRAY WT. -C M: THE NUMBER OF COLUMNS OF DATA IN T. -C N: THE NUMBER OF ROWS OF DATA IN T. -C T: THE ARRAY BEING SCALED BY WT. -C TEMP: A TEMPORARY SCALAR. -C WT: THE WEIGHTS. -C WTT: THE RESULTS OF WEIGHTING ARRAY T BY WT. -C ARRAY WTT CAN BE THE SAME AS T ONLY IF THE ARRAYS IN WT -C ARE UPPER TRIANGULAR WITH ZEROS BELOW THE DIAGONAL. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DWGHT - - - IF (N.EQ.0 .OR. M.EQ.0) RETURN - - IF (WT(1,1,1).GE.ZERO) THEN - IF (LDWT.GE.N) THEN - IF (LD2WT.GE.M) THEN -C WT IS AN N-ARRAY OF M BY M MATRICES - DO 130 I=1,N - DO 120 J=1,M - TEMP = ZERO - DO 110 K=1,M - TEMP = TEMP + WT(I,J,K)*T(I,K) - 110 CONTINUE - WTT(I,J) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE -C WT IS AN N-ARRAY OF DIAGONAL MATRICES - DO 230 I=1,N - DO 220 J=1,M - WTT(I,J) = WT(I,1,J)*T(I,J) - 220 CONTINUE - 230 CONTINUE - END IF - ELSE - IF (LD2WT.GE.M) THEN -C WT IS AN M BY M MATRIX - DO 330 I=1,N - DO 320 J=1,M - TEMP = ZERO - DO 310 K=1,M - TEMP = TEMP + WT(1,J,K)*T(I,K) - 310 CONTINUE - WTT(I,J) = TEMP - 320 CONTINUE - 330 CONTINUE - ELSE -C WT IS A DIAGONAL MATRICE - DO 430 I=1,N - DO 420 J=1,M - WTT(I,J) = WT(1,1,J)*T(I,J) - 420 CONTINUE - 430 CONTINUE - END IF - END IF - ELSE -C WT IS A SCALAR - DO 520 J=1,M - DO 510 I=1,N - WTT(I,J) = ABS(WT(1,1,1))*T(I,J) - 510 CONTINUE - 520 CONTINUE - END IF - - RETURN - END -*DWINF - SUBROUTINE DWINF - + (N,M,NP,NQ,LDWE,LD2WE,ISODR, - + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, - + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, - + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, - + PARTLI,SSTOLI,TAUFCI,EPSMAI, - + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, - + FSI,FJACBI,WE1I,DIFFI, - + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, - + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, - + LWKMN) -C***BEGIN PROLOGUE DWINF -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE -C***END PROLOGUE DWINF - -C...SCALAR ARGUMENTS - INTEGER - + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, - + DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LWKMN, - + M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, - + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI, - + WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, - + WSSI,WSSDEI,WSSEPI,XPLUSI - LOGICAL - + ISODR - -C...LOCAL SCALARS - INTEGER - + NEXT - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. -C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. -C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. -C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. -C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. -C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. -C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. -C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. -C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. -C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. -C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. -C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. -C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. -C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. -C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. -C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. -C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF VECTOR WORK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NEXT: THE NEXT AVAILABLE LOCATION WITH WORK. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. -C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. -C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. -C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. -C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. -C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. -C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCONDI. -C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. -C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. -C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. -C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. -C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. -C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. -C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. -C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. -C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. -C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. -C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. -C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. -C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. -C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. -C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. -C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. -C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. -C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. -C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. -C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. -C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. -C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. -C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. -C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. -C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. - - -C***FIRST EXECUTABLE STATEMENT DWINF - - - IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. - + LDWE.GE.1 .AND. LD2WE.GE.1) THEN - - DELTAI = 1 - EPSI = DELTAI + N*M - XPLUSI = EPSI + N*NQ - FNI = XPLUSI + N*M - SDI = FNI + N*NQ - VCVI = SDI + NP - RVARI = VCVI + NP*NP - - WSSI = RVARI + 1 - WSSDEI = WSSI + 1 - WSSEPI = WSSDEI + 1 - RCONDI = WSSEPI + 1 - ETAI = RCONDI + 1 - OLMAVI = ETAI + 1 - - TAUI = OLMAVI + 1 - ALPHAI = TAUI + 1 - ACTRSI = ALPHAI + 1 - PNORMI = ACTRSI + 1 - RNORSI = PNORMI + 1 - PRERSI = RNORSI + 1 - PARTLI = PRERSI + 1 - SSTOLI = PARTLI + 1 - TAUFCI = SSTOLI + 1 - EPSMAI = TAUFCI + 1 - BETA0I = EPSMAI + 1 - - BETACI = BETA0I + NP - BETASI = BETACI + NP - BETANI = BETASI + NP - SI = BETANI + NP - SSI = SI + NP - SSFI = SSI + NP - QRAUXI = SSFI + NP - UI = QRAUXI + NP - FSI = UI + NP - - FJACBI = FSI + N*NQ - - WE1I = FJACBI + N*NP*NQ - - DIFFI = WE1I + LDWE*LD2WE*NQ - - NEXT = DIFFI + NQ*(NP+M) - - IF (ISODR) THEN - DELTSI = NEXT - DELTNI = DELTSI + N*M - TI = DELTNI + N*M - TTI = TI + N*M - OMEGAI = TTI + N*M - FJACDI = OMEGAI + NQ*NQ - WRK1I = FJACDI + N*M*NQ - NEXT = WRK1I + N*M*NQ - ELSE - DELTSI = DELTAI - DELTNI = DELTAI - TI = DELTAI - TTI = DELTAI - OMEGAI = DELTAI - FJACDI = DELTAI - WRK1I = DELTAI - END IF - - WRK2I = NEXT - WRK3I = WRK2I + N*NQ - WRK4I = WRK3I + NP - WRK5I = WRK4I + M*M - WRK6I = WRK5I + M - WRK7I = WRK6I + N*NQ*NP - NEXT = WRK7I + 5*NQ - - LWKMN = NEXT - ELSE - DELTAI = 1 - EPSI = 1 - XPLUSI = 1 - FNI = 1 - SDI = 1 - VCVI = 1 - RVARI = 1 - WSSI = 1 - WSSDEI = 1 - WSSEPI = 1 - RCONDI = 1 - ETAI = 1 - OLMAVI = 1 - TAUI = 1 - ALPHAI = 1 - ACTRSI = 1 - PNORMI = 1 - RNORSI = 1 - PRERSI = 1 - PARTLI = 1 - SSTOLI = 1 - TAUFCI = 1 - EPSMAI = 1 - BETA0I = 1 - BETACI = 1 - BETASI = 1 - BETANI = 1 - SI = 1 - SSI = 1 - SSFI = 1 - QRAUXI = 1 - FSI = 1 - UI = 1 - FJACBI = 1 - WE1I = 1 - DIFFI = 1 - DELTSI = 1 - DELTNI = 1 - TI = 1 - TTI = 1 - FJACDI = 1 - OMEGAI = 1 - WRK1I = 1 - WRK2I = 1 - WRK3I = 1 - WRK4I = 1 - WRK5I = 1 - WRK6I = 1 - WRK7I = 1 - LWKMN = 1 - END IF - - RETURN - END -*DXMY - SUBROUTINE DXMY - + (N,M,X,LDX,Y,LDY,XMY,LDXMY) -C***BEGIN PROLOGUE DXMY -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE COMPUTE XMY = X - Y -C***END PROLOGUE DXMY - -C...SCALAR ARGUMENTS - INTEGER - + LDX,LDXMY,LDY,M,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + X(LDX,M),XMY(LDXMY,M),Y(LDY,M) - -C...LOCAL SCALARS - INTEGER - + I,J - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN INDEXING VARIABLE. -C J: AN INDEXING VARIABLE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDXMY: THE LEADING DIMENSION OF ARRAY XMY. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. -C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. -C X: THE FIRST OF THE TWO ARRAYS. -C XMY: THE VALUES OF X-Y. -C Y: THE SECOND OF THE TWO ARRAYS. - - -C***FIRST EXECUTABLE STATEMENT DXMY - - - DO 20 J=1,M - DO 10 I=1,N - XMY(I,J) = X(I,J) - Y(I,J) - 10 CONTINUE - 20 CONTINUE - - RETURN - END -*DXPY - SUBROUTINE DXPY - + (N,M,X,LDX,Y,LDY,XPY,LDXPY) -C***BEGIN PROLOGUE DXPY -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE COMPUTE XPY = X + Y -C***END PROLOGUE DXPY - -C...SCALAR ARGUMENTS - INTEGER - + LDX,LDXPY,LDY,M,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + X(LDX,M),XPY(LDXPY,M),Y(LDY,M) - -C...LOCAL SCALARS - INTEGER - + I,J - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C I: AN INDEXING VARIABLE. -C J: AN INDEXING VARIABLE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDXPY: THE LEADING DIMENSION OF ARRAY XPY. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. -C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. -C X: THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER. -C XPY: THE VALUES OF X+Y. -C Y: THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER. - - -C***FIRST EXECUTABLE STATEMENT DXPY - - - DO 20 J=1,M - DO 10 I=1,N - XPY(I,J) = X(I,J) + Y(I,J) - 10 CONTINUE - 20 CONTINUE - - RETURN - END -*DZERO - SUBROUTINE DZERO - + (N,M,A,LDA) -C***BEGIN PROLOGUE DZERO -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920304 (YYMMDD) -C***PURPOSE SET A = ZERO -C***END PROLOGUE DZERO - -C...SCALAR ARGUMENTS - INTEGER - + LDA,M,N - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + A(LDA,M) - -C...LOCAL SCALARS - DOUBLE PRECISION - + ZERO - INTEGER - + I,J - -C...DATA STATEMENTS - DATA - + ZERO - + /0.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C A: THE ARRAY TO BE SET TO ZERO. -C I: AN INDEXING VARIABLE. -C J: AN INDEXING VARIABLE. -C LDA: THE LEADING DIMENSION OF ARRAY A. -C M: THE NUMBER OF COLUMNS TO BE SET TO ZERO. -C N: THE NUMBER OF ROWS TO BE SET TO ZERO. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DZERO - - - DO 20 J=1,M - DO 10 I=1,N - A(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - - RETURN - END diff --git a/scipy/odr/odrpack/d_test.f b/scipy/odr/odrpack/d_test.f deleted file mode 100644 index 296aec1f1674..000000000000 --- a/scipy/odr/odrpack/d_test.f +++ /dev/null @@ -1,2198 +0,0 @@ -*DTEST - PROGRAM DTEST -C***BEGIN PROLOGUE TEST -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DODRX -C***DATE WRITTEN 861229 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE EXERCISE FEATURES OF ODRPACK SOFTWARE -C***END PROLOGUE ODRPACK - -C...SCALARS IN COMMON - INTEGER - + NTEST - -C...LOCAL SCALARS - DOUBLE PRECISION - + TSTFAC - INTEGER - + LUNERR,LUNRPT,LUNSUM - LOGICAL - + PASSED - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DODRX - -C...COMMON BLOCKS - COMMON /TSTSET/ NTEST - -C***VARIABLE DECLARATIONS (ALPHABETICALLY) - -C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. -C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C LUNSUM: THE LOGICAL UNIT NUMBER USED FOR A SUMMARY REPORT LISTING -C ONLY THE TEST COMPARISONS AND NOT THE ODRPACK GENERATED -C REPORTS. -C NTEST: THE NUMBER OF TESTS TO BE RUN. -C PASSED: THE VARIABLE DESIGNATING WHETHER THE RESULTS OF ALL OF THE -C TESTS AGREE WITH THOSE FROM THE CRAY YMP USING DOUBLE -C PRECISION (PASSED=TRUE), OR WHETHER SOME OF THE RESULTS -C DISAGREED (PASSED=FALSE). -C TSTFAC: THE USER-SUPPLIED FACTOR FOR SCALING THE TEST TOLERANCES -C USED TO CHECK FOR AGREEMENT BETWEEN COMPUTED RESULTS AND -C RESULTS OBTAINED USING DOUBLE PRECISION VERSION ON CRAY -C YMP. VALUES OF TSTFAC GREATER THAN ONE INCREASE THE -C TEST TOLERANCES, MAKING THE TESTS EASIER TO PASS AND -C ALLOWING SMALL DISCREPANCIES BETWEEN THE COMPUTED AND -C EXPECTED RESULTS TO BE AUTOMATICALLY DISCOUNTED. - - -C***FIRST EXECUTABLE STATEMENT TEST - - -C SET UP NECESSARY FILES - -C NOTE: ODRPACK GENERATES COMPUTATION AND ERROR REPORTS ON -C LOGICAL UNIT 6 BY DEFAULT; -C LOGICAL UNIT 'LUNSUM' USED TO SUMMARIZE RESULTS OF COMPARISONS -C FROM EXERCISE ROUTINE DODRX. - - LUNRPT = 18 - LUNERR = 18 - LUNSUM = 19 - - OPEN(UNIT=LUNRPT,FILE='REPORT') - OPEN(UNIT=LUNERR,FILE='REPORT') - OPEN(UNIT=LUNSUM,FILE='SUMMARY') - -C EXERCISE DOUBLE PRECISION VERSION OF ODRPACK -C (TEST REPORTS GENERATED ON FILE 'RESULTS' AND -C SUMMARIZED IN FILE 'SUMMARY') - - NTEST = 12 - TSTFAC = 1.0D0 - CALL DODRX(TSTFAC,PASSED,LUNSUM) - - END -*DODRX - SUBROUTINE DODRX - + (TSTFAC,PASSED,LUNSUM) -C***BEGIN PROLOGUE DODRX -C***REFER TO DODR,DODRC -C***ROUTINES CALLED DDOT,DMPREC,DNRM2,DODR,DODRC,DODRXD, -C DODRXF,DODRXW,DWGHT,DZERO -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE EXERCISE FEATURES OF ODRPACK SOFTWARE -C***END PROLOGUE DODRX - -C...PARAMETERS - INTEGER - + LDWD,LDWE,LD2WD,LD2WE,LIWORK,LWORK,MAXN,MAXM,MAXNP,MAXNQ,NTESTS - PARAMETER - + (MAXN=50, MAXM=3, MAXNP=10, MAXNQ=2, NTESTS=12, - + LDWE=MAXN, LD2WE=MAXNQ, LDWD=MAXN, LD2WD=MAXM, - + LWORK = 18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + - + 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + - + 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + - + 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ, - + LIWORK = 20+MAXNP+MAXNQ*(MAXNP+MAXM)) - -C...SCALAR ARGUMENTS - DOUBLE PRECISION - + TSTFAC - INTEGER - + LUNSUM - LOGICAL - + PASSED - -C...SCALARS IN COMMON - INTEGER - + NTEST,SETNO - -C...LOCAL SCALARS - INTEGER - + I,INFO,IPRINT,ITEST,JOB,L,LDIFX,LDSCLD,LDSTPD,LDWD1,LDWE1, - + LDX,LDY,LD2WD1,LD2WE1,LIWMIN,LUN,LUNERR,LUNRPT,LWMIN, - + M,MAXIT,MSG,N,NDIGIT,NP,NQ - DOUBLE PRECISION - + BNRM,EPSMAC,HUNDRD,ONE,P01,P2,PARTOL,SSTOL, - + TAUFAC,THREE,TSTTOL,TWO,WSS,WSSDEL,WSSEPS,ZERO - LOGICAL - + FAILED,FAILS,ISODR,SHORT - CHARACTER TITLE*80 - -C...LOCAL ARRAYS - DOUBLE PRECISION - + BETA(MAXNP),DPYMP(2,NTESTS), - + SCLB(MAXNP),SCLD(MAXN,MAXM), - + STPB(MAXNP),STPD(MAXN,MAXM), - + WE(MAXN,MAXNQ,MAXNQ),WD(MAXN,MAXM,MAXM),WORK(LWORK), - + WRK(MAXN*MAXM+MAXN*MAXNQ),X(MAXN,MAXM),Y(MAXN,MAXNQ) - INTEGER - + IDPYMP(NTESTS),IFIXB(MAXNP),IFIXX(MAXN,MAXM),IWORK(LIWORK) - -C...EXTERNAL FUNCTIONS - DOUBLE PRECISION - + DDOT,DMPREC,DNRM2 - EXTERNAL - + DDOT,DMPREC,DNRM2 - -C...EXTERNAL SUBROUTINES - EXTERNAL - + DODR,DODRC,DODRXD,DODRXF,DODRXW,DWGHT,DZERO - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ABS,MOD - -C...COMMON BLOCKS - COMMON /SETID/SETNO - COMMON /TSTSET/ NTEST - -C...DATA STATEMENTS - DATA - + ZERO,P01,P2,ONE,TWO,THREE,HUNDRD - + /0.0D0,0.01D0,0.2D0,1.0D0,2.0D0,3.0D0,100.0D0/ - - DATA - + (DPYMP(I,1),I=1,2) - + /2.762733195780256808978449342964D+04, - + 7.532639569022918943695104672512D-04/ - DATA - + (DPYMP(I,2),I=1,2) - + /2.762732630143673024399942947263D+04, - + 7.538467722687131506874279314940D-04/ - DATA - + (DPYMP(I,3),I=1,2) - + /1.069944100000000027940905194068D+09, - + 1.212808593256056359629660672046D-05/ - DATA - + (DPYMP(I,4),I=1,2) - + /1.069944100000000026623461142867D+09, - + 5.452084633790606017572015067556D-07/ - DATA - + (DPYMP(I,5),I=1,2) - + /1.426988156377258617521571734503D+00, - + 1.084728687127432219753903919409D+00/ - DATA - + (DPYMP(I,6),I=1,2) - + /4.261321829513978871872508874025D+00, - + 1.477967210398420733565424329280D-02/ - DATA - + (DPYMP(I,7),I=1,2) - + /4.261272307142888464011486769858D+00, - + 1.477966125465374336804138554559D-02/ - DATA - + (DPYMP(I,8),I=1,2) - + /4.371487317909745009110272283622D+01, - + 1.144419474408286067112233592550D-03/ - DATA - + (DPYMP(I,9),I=1,2) - + /3.099048849376848610380977303924D+00, - + 8.824708863783850023783338218501D-02/ - DATA - + (DPYMP(I,10),I=1,2) - + /9.469917836739932584221023234527D+00, - + 4.205389215588104651198536809880D-01/ - DATA - + (DPYMP(I,11),I=1,2) - + /3.950949253027682207109233363651D+01, - + 6.651838750834910819636881506915D+01/ - DATA - + (DPYMP(I,12),I=1,2) - + /3.950949253027682207109233363651D+01, - + 6.651838750834910819636881506915D+01/ - - DATA - + (IDPYMP(I),I=1,12) - + /1,1,3,1,1,4,1,1,2,1,1023,40100/ - -C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS -C DODRXF: THE USER-SUPPLIED ROUTINE FOR EVALUATING THE MODEL. - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: THE FUNCTION PARAMETERS. -C BNRM: THE NORM OF BETA. -C DPYMP: THE FLOATING POINT RESULTS FROM A CRAY YMP USING -C DOUBLE PRECISION. -C EPSMAC: THE VALUE OF MACHINE PRECISION. -C FAILED: THE VARIABLE DESIGNATING WHETHER THE RESULTS OF ALL OF THE -C DEMONSTRATION RUNS AGREED WITH THOSE FROM THE CRAY YMP -C USING DOUBLE PRECISION (FAILED=FALSE) OR WHETHER SOME OF -C THE TESTS DISAGREED (FAILED=TRUE). -C FAILS: THE VARIABLE DESIGNATING WHETHER THE RESULTS OF AN -C INDIVIDUAL DEMONSTRATION RUN AGREED WITH THOSE FROM THE -C CRAY YMP USING DOUBLE PRECISION (FAILS=FALSE) OR -C DISAGREE (FAILS=TRUE). -C HUNDRD: THE VALUE 100.0D0. -C I: AN INDEX VARIABLE. -C IDPYMP: THE INTEGER RESULTS FROM A CRAY YMP USING -C DOUBLE PRECISION. -C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE -C FIXED AT THEIR INPUT VALUES OR NOT. -C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS STOPPED. -C IPRINT: THE PRINT CONTROL VARIABLE. -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C ITEST: THE NUMBER OF THE CURRENT TEST BEING RUN. -C IWORK: THE INTEGER WORK SPACE. -C J: AN INDEX VARIABLE. -C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND -C COMPUTATIONAL METHOD. -C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. -C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. -C LDWD: THE LEADING DIMENSION OF ARRAY WD. -C LDWD1: THE LEADING DIMENSION OF ARRAY WD AS PASSED TO ODRPACK. -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LDWE1: THE LEADING DIMENSION OF ARRAY WE AS PASSED TO ODRPACK. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C LDY: THE LEADING DIMENSION OF ARRAY Y. -C LD2WD: THE SECOND DIMENSION OF ARRAY WD. -C LD2WD1: THE SECOND DIMENSION OF ARRAY WD AS PASSED TO ODRPACK. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LD2WE1: THE SECOND DIMENSION OF ARRAY WE AS PASSED TO ODRPACK. -C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. -C LIWMIN: THE MINIMUM LENGTH OF VECTOR IWORK FOR A GIVEN PROBLEM. -C LIWORK: THE LENGTH OF VECTOR IWORK. -C LUN: THE LOGICAL UNIT NUMBER CURRENTLY BEING USED. -C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. -C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. -C LUNSUM: THE LOGICAL UNIT NUMBER USED FOR A SUMMARY REPORT. -C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. -C LWMIN: THE MINIMUM LENGTH OF VECTOR WORK FOR A GIVEN PROBLEM. -C LWORK: THE LENGTH OF VECTOR WORK. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. -C MSG: THE VARIABLE DESIGNATING WHICH MESSAGE IS TO BE PRINTED AS -C A RESULT OF THE COMPARISON WITH THE CRAY YMP RESULTS. -C N: THE NUMBER OF OBSERVATIONS. -C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS -C SUPPLIED BY THE USER. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NTEST: THE NUMBER OF TESTS TO BE RUN. -C NTESTS: THE NUMBER OF DIFFERENT TESTS AVAILABLE. -C ONE: THE VALUE 1.0D0. -C PASSED: THE VARIABLE DESIGNATING WHETHER THE RESULTS OF ALL OF THE -C DEMONSTRATION RUNS AGREED WITH THOSE FROM THE CRAY YMP -C USING DOUBLE PRECISION (PASSED=TRUE), OR WHETHER SOME OF -C THE RESULTS DISAGREED (PASSED=FALSE). -C P01: THE VALUE 0.01D0. -C P2: THE VALUE 0.2D0. -C PARTOL: THE PARAMETER CONVERGENCE STOPPING CRITERIA. -C SCLB: THE SCALING VALUES FOR BETA. -C SCLD: THE SCALING VALUES FOR DELTA. -C SETNO: THE NUMBER OF THE DATA SET BEING ANALYZED. -C SHORT: THE VARIABLE DESIGNATING WHETHER ODRPACK IS INVOKED BY THE -C SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL (SHORT=.FALSE.). -C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. -C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION -C DIAMETER. -C THREE: THE VALUE 3.0D0. -C TITLE: THE REFERENCE FOR THE DATA SET BEING ANALYZED. -C TSTFAC: THE USER-SUPPLIED FACTOR FOR SCALING THE TEST TOLERANCES -C USED TO CHECK FOR AGREEMENT BETWEEN COMPUTED RESULTS AND -C RESULTS OBTAINED USING DOUBLE PRECISION VERSION ON CRAY -C YMP. -C TSTTOL: THE TEST TOLERANCE USED IN CHECKING COMPUTED VALUES FOR -C PURPOSES OF DETERMINING PROPER INSTALLATION. -C TWO: THE VALUE 2.0D0. -C WD: THE DELTA WEIGHTS. -C WE: THE EPSILON WEIGHTS. -C WORK: THE DOUBLE PRECISION WORK SPACE. -C WRK: THE DOUBLE PRECISION WORK SPACE FOR COMPUTING TEST RESULTS. -C WSS: THE SUM OF THE SQUARED WEIGHTED ERRORS. -C WSSDEL: THE SUM OF THE SQUARED WEIGHTED ERRORS IN X. -C WSSEPS: THE SUM OF THE SQUARED WEIGHTED ERRORS IN Y. -C X: THE EXPLANATORY VARIABLE. -C Y: THE RESPONSE VARIABLE. -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODRX - - -C SET LOGICAL UNITS FOR ERROR AND COMPUTATION REPORTS - - LUNERR = 18 - LUNRPT = 18 - -C INITIALIZE TEST TOLERANCE - - IF (TSTFAC.GT.ONE) THEN - TSTTOL = TSTFAC - ELSE - TSTTOL = ONE - END IF - -C INITIALIZE MACHINE PRECISION - - EPSMAC = DMPREC() - -C INITIALIZE LEADING DIMENSION OF X - - LDX = MAXN - LDY = MAXN - -C INITIALIZE MISCELLANEOUS VARIABLES USED IN THE EXERCISE PROCEDURE - - FAILED = .FALSE. - SHORT = .TRUE. - ISODR = .TRUE. - N = 0 - -C BEGIN EXERCISING ODRPACK - - DO 400 ITEST=1,NTEST - -C SET CONTROL VALUES TO INVOKE DEFAULT VALUES - - WE(1,1,1) = -ONE - LDWE1 = LDWE - LD2WE1 = LD2WE - WD(1,1,1) = -ONE - LDWD1 = LDWD - LD2WD1 = LD2WD - - IFIXB(1) = -1 - IFIXX(1,1) = -1 - LDIFX = MAXN - - NDIGIT = -1 - TAUFAC = -ONE - - SSTOL = -ONE - PARTOL = -ONE - MAXIT = -1 - - IPRINT = 2112 - - STPB(1) = -ONE - STPD(1,1) = -ONE - LDSTPD = 1 - - SCLB(1) = -ONE - SCLD(1,1) = -ONE - LDSCLD = 1 - - IF (ITEST.EQ.1) THEN - -C TEST SIMPLE ODR PROBLEM -C WITH ANALYTIC DERIVATIVES. - - LUN = LUNRPT - WRITE (LUN,1000) - DO 10 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1010) - LUN = LUNSUM - 10 CONTINUE - SETNO = 5 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - JOB = 00020 - SHORT = .TRUE. - ISODR = .TRUE. - - ELSE IF (ITEST.EQ.2) THEN - -C TEST SIMPLE OLS PROBLEM -C WITH FORWARD DIFFERENCE DERIVATIVES. - - LUN = LUNRPT - WRITE (LUN,1000) - DO 20 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1020) - LUN = LUNSUM - 20 CONTINUE - SETNO = 5 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - JOB = 00002 - SHORT = .TRUE. - ISODR = .FALSE. - - ELSE IF (ITEST.EQ.3) THEN - -C TEST PARAMETER FIXING CAPABILITIES FOR POORLY SCALED OLS PROBLEM -C WITH ANALYTIC DERIVATIVES. -C (DERIVATIVE CHECKING TURNED OFF.) - - LUN = LUNRPT - WRITE (LUN,1000) - DO 30 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1030) - LUN = LUNSUM - 30 CONTINUE - SETNO = 3 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - IFIXB(1) = 1 - IFIXB(2) = 1 - IFIXB(3) = 1 - IFIXB(4) = 0 - IFIXB(5) = 1 - IFIXB(6) = 0 - IFIXB(7) = 0 - IFIXB(8) = 0 - IFIXB(9) = 0 - JOB = 00042 - SHORT = .FALSE. - ISODR = .FALSE. - - ELSE IF (ITEST.EQ.4) THEN - -C TEST WEIGHTING CAPABILITIES FOR ODR PROBLEM WITH -C ANALYTIC DERIVATIVES. -C ALSO SHOWS SOLUTION OF POORLY SCALED ODR PROBLEM. -C (DERIVATIVE CHECKING TURNED OFF.) -C N.B., THIS RUN CONTINUES FROM WHERE TEST 3 LEFT OFF. - - LUN = LUNRPT - WRITE (LUN,1000) - DO 40 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1040) - LUN = LUNSUM - 40 CONTINUE - SETNO = 3 - CALL DZERO(LWORK,1,WORK,LWORK) - LDWD1 = LDWD - LDWE1 = LDWE - LD2WD1 = LD2WD - LD2WE1 = LD2WE - DO 45 I=1,N - WD(I,1,1) = (P01/ABS(X(I,1)))**2 - WE(I,1,1) = ONE - 45 CONTINUE - WE(28,1,1) = ZERO - IFIXB(1) = 1 - IFIXB(2) = 1 - IFIXB(3) = 1 - IFIXB(4) = 0 - IFIXB(5) = 1 - IFIXB(6) = 1 - IFIXB(7) = 1 - IFIXB(8) = 0 - IFIXB(9) = 0 - JOB = 00030 - IPRINT = 2232 - SHORT = .FALSE. - ISODR = .TRUE. - - ELSE IF (ITEST.EQ.5) THEN - -C TEST DELTA INITIALIZATION CAPABILITIES AND USER-SUPPLIED SCALING -C AND USE OF ISTOP TO RESTRICT PARAMETER VALUES -C FOR ODR PROBLEM WITH ANALYTIC DERIVATIVES. - - LUN = LUNRPT - WRITE (LUN,1000) - DO 50 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1050) - LUN = LUNSUM - 50 CONTINUE - SETNO = 1 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - JOB = 01020 - LDSCLD = 1 - SCLD(1,1) = TWO - SCLB(1) = P2 - SCLB(2) = ONE - LDWE1 = 1 - LD2WE1 = 1 - WE(1,1,1) = -ONE - LDWD1 = 1 - LD2WD1 = 1 - WD(1,1,1) = -ONE - DO 55 I=20,21 - WORK(I) = BETA(1)/Y(I,1) + BETA(2) - X(I,1) - 55 CONTINUE - SHORT = .FALSE. - ISODR = .TRUE. - - ELSE IF (ITEST.EQ.6) THEN - -C TEST STIFF STOPPING CONDITIONS FOR UNSCALED ODR PROBLEM -C WITH ANALYTIC DERIVATIVES. - - LUN = LUNRPT - WRITE (LUN,1000) - DO 60 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1060) - LUN = LUNSUM - 60 CONTINUE - SETNO = 4 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - JOB = 00020 - SSTOL = HUNDRD*EPSMAC - PARTOL = EPSMAC - MAXIT = 2 - SHORT = .FALSE. - ISODR = .TRUE. - - ELSE IF (ITEST.EQ.7) THEN - -C TEST RESTART FOR UNSCALED ODR PROBLEM -C WITH ANALYTIC DERIVATIVES. - - LUN = LUNRPT - WRITE (LUN,1000) - DO 70 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1070) - LUN = LUNSUM - 70 CONTINUE - SETNO = 4 - JOB = 20220 - SSTOL = HUNDRD*EPSMAC - PARTOL = EPSMAC - MAXIT = 50 - SHORT = .FALSE. - ISODR = .TRUE. - - ELSE IF (ITEST.EQ.8) THEN - -C TEST USE OF TAUFAC TO RESTRICT FIRST STEP -C FOR ODR PROBLEM WITH CENTRAL DIFFERENCE DERIVATIVES. - - LUN = LUNRPT - WRITE (LUN,1000) - DO 80 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1080) - LUN = LUNSUM - 80 CONTINUE - SETNO = 6 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - JOB = 00210 - TAUFAC = P01 - SHORT = .FALSE. - ISODR = .TRUE. - - ELSE IF (ITEST.EQ.9) THEN - -C TEST IMPLICIT ODR PROBLEM -C WITH FORWARD FINITE DIFFERENCE DERIVATIVES -C AND COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES. - - - LUN = LUNRPT - WRITE (LUN,1000) - DO 90 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1090) - LUN = LUNSUM - 90 CONTINUE - SETNO = 7 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - JOB = 00001 - PARTOL = EPSMAC**(ONE/THREE) - SHORT = .TRUE. - ISODR = .TRUE. - - ELSE IF (ITEST.EQ.10) THEN - -C TEST MULTIRESPONSE ODR PROBLEM -C WITH CENTRAL DIFFERENCE DERIVATIVES , -C DELTA INITIALIZED TO NONZERO VALUES, -C VARIABLE FIXING, AND WEIGHTING. - - LUN = LUNRPT - WRITE (LUN,1000) - DO 100 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1100) - LUN = LUNSUM - 100 CONTINUE - SETNO = 8 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - - LDWD1 = LDWD - LDWE1 = LDWE - LD2WD1 = LD2WD - LD2WE1 = LD2WE - DO 105 I=1,N -C INITIALIZE DELTA, AND SPECIFY FIRST DECADE OF FREQUENCIES AS FIXED - IF (X(I,1).LT.100.0D0) THEN - WORK(I) = 0.0D0 - IFIXX(I,1) = 0 - ELSE IF (X(I,1).LE.150.0D0) THEN - WORK(I) = 0.0D0 - IFIXX(I,1) = 1 - ELSE IF (X(I,1).LE.1000.0D0) THEN - WORK(I) = 25.0D0 - IFIXX(I,1) = 1 - ELSE IF (X(I,1).LE.10000.0D0) THEN - WORK(I) = 560.0D0 - IFIXX(I,1) = 1 - ELSE IF (X(I,1).LE.100000.0D0) THEN - WORK(I) = 9500.0D0 - IFIXX(I,1) = 1 - ELSE - WORK(I) = 144000.0D0 - IFIXX(I,1) = 1 - END IF - -C SET WEIGHTS - IF (X(I,1).EQ.100.0D0 .OR. X(I,1).EQ.150.0D0) THEN - WE(I,1,1) = 0.0D0 - WE(I,1,2) = 0.0D0 - WE(I,2,1) = 0.0D0 - WE(I,2,2) = 0.0D0 - ELSE - WE(I,1,1) = 559.6D0 - WE(I,1,2) = -1634.0D0 - WE(I,2,1) = -1634.0D0 - WE(I,2,2) = 8397.0D0 - END IF - WD(I,1,1) = (1.0D-4)/(X(I,1)**2) - 105 CONTINUE - JOB = 00210 - SHORT = .FALSE. - ISODR = .TRUE. - - ELSE IF (ITEST.EQ.11) THEN - -C TEST DETECTION OF INCORRECT DERIVATIVES - - LUN = LUNRPT - WRITE (LUN,1000) - DO 110 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1110) - LUN = LUNSUM - 110 CONTINUE - SETNO = 6 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - JOB = 00022 - SHORT = .FALSE. - ISODR = .FALSE. - - ELSE IF (ITEST.EQ.12) THEN - -C TEST DETECTION OF INCORRECT DERIVATIVES - - LUN = LUNRPT - WRITE (LUN,1000) - DO 120 I=1,2 - WRITE (LUN,1001) ITEST - WRITE (LUN,1120) - LUN = LUNSUM - 120 CONTINUE - SETNO = 6 - CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) - CALL DZERO(LWORK,1,WORK,LWORK) - JOB = 00020 - SHORT = .FALSE. - ISODR = .TRUE. - - END IF - - CALL DODRXW - + (N,M,NP,NQ,LDWE1,LD2WE1,ISODR,LIWMIN,LWMIN) - -C COMPUTE SOLUTION - - WRITE (LUNRPT,2200) TITLE - WRITE (LUNSUM,2200) TITLE - IF (SHORT) THEN - CALL DODR(DODRXF, - + N,M,NP,NQ, - + BETA, - + Y,LDY,X,LDX, - + WE,LDWE1,LD2WE1,WD,LDWD1,LD2WD1, - + JOB, - + IPRINT,LUNERR,LUNRPT, - + WORK,LWMIN,IWORK,LIWMIN, - + INFO) - ELSE - CALL DODRC(DODRXF, - + N,M,NP,NQ, - + BETA, - + Y,LDY,X,LDX, - + WE,LDWE1,LD2WE1,WD,LDWD1,LD2WD1, - + IFIXB,IFIXX,LDIFX, - + JOB,NDIGIT,TAUFAC, - + SSTOL,PARTOL,MAXIT, - + IPRINT,LUNERR,LUNRPT, - + STPB,STPD,LDSTPD, - + SCLB,SCLD,LDSCLD, - + WORK,LWMIN,IWORK,LIWMIN, - + INFO) - END IF - -C COMPARE RESULTS WITH THOSE OBTAINED ON THE CRAY YMP -C USING DOUBLE PRECISION VERSION OF ODRPACK - - BNRM = DNRM2(NP,BETA,1) - CALL DWGHT(N,M,WD,LDWD1,LD2WD1,WORK(1),N,WRK(1),N) - WSSDEL = DDOT(N*M,WORK(1),1,WRK(1),1) - CALL DWGHT(N,NQ,WE,LDWE1,LD2WE1,WORK(N*M+1),N,WRK(N*M+1),N) - WSSEPS = DDOT(N*NQ,WORK(N*M+1),1,WRK(N*M+1),1) - WSS = WSSEPS + WSSDEL - - IF (SSTOL.LT.ZERO) THEN - SSTOL = SQRT(EPSMAC) - ELSE - SSTOL = MIN(SSTOL, ONE) - END IF - - IF (PARTOL.LT.ZERO) THEN - PARTOL = EPSMAC**(TWO/THREE) - ELSE - PARTOL = MIN(PARTOL, ONE) - END IF - - IF (INFO.GE.10000) THEN - IF (IDPYMP(ITEST).EQ.INFO) THEN - FAILS = .FALSE. - MSG = 1 - ELSE - FAILS = .TRUE. - MSG = 3 - END IF - - ELSE IF (MOD(INFO,10).EQ.1) THEN - FAILS = ABS(WSS-DPYMP(2,ITEST)).GT. - + DPYMP(2,ITEST)*SSTOL*TSTTOL - MSG = 2 - - ELSE IF (MOD(INFO,10).EQ.2) THEN - FAILS = ABS(BNRM-DPYMP(1,ITEST)).GT. - + DPYMP(1,ITEST)*PARTOL*TSTTOL - MSG = 2 - - ELSE IF (MOD(INFO,10).EQ.3) THEN - FAILS = (ABS(WSS-DPYMP(2,ITEST)).GT. - + DPYMP(2,ITEST)*SSTOL*TSTTOL) - + .AND. - + (ABS(BNRM-DPYMP(1,ITEST)).GT. - + DPYMP(1,ITEST)*PARTOL*TSTTOL) - MSG = 2 - - ELSE IF ((MOD(INFO,10).EQ.4) .AND. (IDPYMP(ITEST).EQ.4)) THEN - FAILS = .FALSE. - MSG = 1 - - ELSE IF (INFO.EQ.IDPYMP(ITEST)) THEN - FAILS = .TRUE. - MSG = 4 - ELSE - FAILS = .TRUE. - MSG = 3 - END IF - - FAILED = FAILED .OR. FAILS - - LUN = LUNRPT - DO 300 L=1,2 - WRITE (LUN,3100) - WRITE (LUN,3210) ' CRAY YMP RESULT = ', - + DPYMP(1,ITEST),DPYMP(2,ITEST),IDPYMP(ITEST) - WRITE (LUN,3210) ' NEW TEST RESULT = ', - + BNRM,WSS,INFO - WRITE (LUN,3220) ' DIFFERENCE = ', - + ABS(DPYMP(1,ITEST)-BNRM),ABS(DPYMP(2,ITEST)-WSS) - WRITE (LUN,3220) ' RELATIVE ERROR = ', - + ABS(DPYMP(1,ITEST)-BNRM)/ABS(DPYMP(1,ITEST)), - + ABS(DPYMP(2,ITEST)-WSS)/ABS(DPYMP(2,ITEST)) - - IF (MSG.EQ.1) THEN - WRITE (LUN,3310) - ELSE IF (MSG.EQ.2) THEN - IF (FAILS) THEN - WRITE (LUN,3320) - ELSE - WRITE (LUN,3330) - END IF - ELSE IF (MSG.EQ.3) THEN - WRITE (LUN,3340) - ELSE IF (MSG.EQ.4) THEN - WRITE (LUN,3350) - END IF - - LUN = LUNSUM - 300 CONTINUE - 400 CONTINUE - - WRITE (LUNRPT,1000) - IF (FAILED) THEN - WRITE (LUNRPT,4100) - WRITE (LUNSUM,4100) - PASSED = .FALSE. - ELSE - WRITE (LUNRPT,4200) - WRITE (LUNSUM,4200) - PASSED = .TRUE. - END IF - -C FORMAT STATEMENTS - - 1000 FORMAT('1') - 1001 FORMAT(' EXAMPLE ', I2/) - 1010 FORMAT(' TEST SIMPLE ODR PROBLEM'/ - + ' WITH ANALYTIC DERIVATIVES', - + ' USING DODR.') - 1020 FORMAT(' TEST SIMPLE OLS PROBLEM'/ - + ' WITH FINITE DIFFERENCE DERIVATIVES', - + ' USING DODR.') - 1030 FORMAT(' TEST PARAMETER FIXING CAPABILITIES', - + ' FOR POORLY SCALED OLS PROBLEM'/ - + ' WITH ANALYTIC DERIVATIVES', - + ' USING DODRC.') - 1040 FORMAT(' TEST WEIGHTING CAPABILITIES', - + ' FOR ODR PROBLEM'/ - + ' WITH ANALYTIC DERIVATIVES', - + ' USING DODRC. '/ - + ' ALSO SHOWS SOLUTION OF POORLY SCALED', - + ' ODR PROBLEM.'/ - + ' (DERIVATIVE CHECKING TURNED OFF.)') - 1050 FORMAT(' TEST DELTA INITIALIZATION CAPABILITIES'/ - + ' AND USE OF ISTOP TO RESTRICT PARAMETER VALUES', - + ' FOR ODR PROBLEM'/ - + ' WITH ANALYTIC DERIVATIVES', - + ' USING DODRC.') - 1060 FORMAT(' TEST STIFF STOPPING CONDITIONS', - + ' FOR UNSCALED ODR PROBLEM'/ - + ' WITH ANALYTIC DERIVATIVES', - + ' USING DODRC.') - 1070 FORMAT(' TEST RESTART', - + ' FOR UNSCALED ODR PROBLEM'/ - + ' WITH ANALYTIC DERIVATIVES', - + ' USING DODRC.') - 1080 FORMAT(' TEST USE OF TAUFAC TO RESTRICT FIRST STEP', - + ' FOR ODR PROBLEM'/ - + ' WITH FINITE DIFFERENCE DERIVATIVES', - + ' USING DODRC.') - 1090 FORMAT(' TEST IMPLICIT MODEL', - + ' FOR OLS PROBLEM'/ - + ' USING DODRC.') - 1100 FORMAT(' TEST MULTIRESPONSE MODEL', - + ' FOR ODR PROBLEM'/ - + ' WITH FINITE DIFFERENCE DERIVATIVES', - + ' USING DODRC.') - 1110 FORMAT(' TEST DETECTION OF QUESTIONABLE ANALYTIC DERIVATIVES', - + ' FOR OLS PROBLEM'/ - + ' USING DODRC.') - 1120 FORMAT(' TEST DETECTION OF INCORRECT ANALYTIC DERIVATIVES', - + ' FOR ODR PROBLEM'/ - + ' WITH ANALYTIC DERIVATIVES', - + ' USING DODRC.') - 2200 FORMAT (' DATA SET REFERENCE: ', A80) - 3100 FORMAT - + (/' COMPARISON OF NEW RESULTS WITH', - + ' DOUBLE PRECISION CRAY YMP RESULT:'// - + ' NORM OF BETA', - + ' SUM OF SQUARED WTD OBS ERRORS INFO') - 3210 FORMAT - + (/A25/1P,2D37.30,I6) - 3220 FORMAT - + (/A25,1P,D12.5,25X,D12.5,I6) - 3310 FORMAT - + (/' *** STOPPING CONDITIONS', - + ' SHOW CONVERGENCE NOT ATTAINED. ***'/ - + ' NO FURTHER COMPARISONS MADE BETWEEN RESULTS.'//) - 3320 FORMAT - + (//' *** WARNING ***', - + ' RESULTS DO NOT AGREE TO WITHIN STOPPING TOLERANCE. ***'//) - 3330 FORMAT - + (//' *** RESULTS AGREE TO WITHIN STOPPING TOLERANCE. ***'//) - 3340 FORMAT - + (//' *** WARNING ***', - + ' STOPPING CONDITIONS DO NOT AGREE. ***'//) - 3350 FORMAT - + (//' *** WARNING ***', - + ' UNEXPECTED STOPPING CONDITION.', - + ' PLEASE CONTACT PACKAGE AUTHORS. ***'//) - 4100 FORMAT - + (/// - + ' *** SUMMARY:', - + ' ONE OR MORE TESTS DO NOT AGREE WITH EXPECTED RESULTS. ***') - 4200 FORMAT - + (/// - + ' *** SUMMARY:', - + ' ALL TESTS AGREE WITH EXPECTED RESULTS. ***') - - END -*DODRXD - SUBROUTINE DODRXD - + (TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) -C***BEGIN PROLOGUE DODRXD -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE SET UP DATA FOR ODRPACK EXERCISER -C***END PROLOGUE DODRXD - -C...PARAMETERS - INTEGER - + MAXN,MAXM,MAXNP,MAXNQ,MAXSET - PARAMETER - + (MAXN=50,MAXM=3,MAXNP=10,MAXNQ=3,MAXSET=10) - -C...SCALAR ARGUMENTS - INTEGER - + LDX,LDY,M,N,NP,NQ - CHARACTER TITLE*80 - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(*),X(LDX,*),Y(LDY,*) - -C...SCALARS IN COMMON - INTEGER - + SETNO - -C...LOCAL SCALARS - INTEGER - + I,J,K,L - -C...LOCAL ARRAYS - DOUBLE PRECISION - + BDATA(MAXNP,MAXSET),XDATA(MAXN,MAXM,MAXSET), - + YDATA(MAXN,MAXNQ,MAXSET) - INTEGER - + MDATA(MAXSET),NDATA(MAXSET),NPDATA(MAXSET),NQDATA(MAXSET) - CHARACTER TDATA(MAXSET)*80 - -C...COMMON BLOCKS - COMMON /SETID/SETNO - -C...DATA STATEMENTS - DATA - + TDATA(1) - + /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1'/ - DATA - + NDATA(1), MDATA(1), NPDATA(1), NQDATA(1) - + /40, 1, 2, 1/ - DATA - + (BDATA(K,1),K=1,2) - + /1.0D+0, 1.0D+0/ - DATA - + YDATA( 1,1,1), XDATA( 1,1,1) - + /-0.119569795672791172D+1, -0.213701920211315155D-1/ - DATA - + YDATA( 2,1,1), XDATA( 2,1,1) - + /-0.128023349509594288D+1, 0.494813247025012969D-1/ - DATA - + YDATA( 3,1,1), XDATA( 3,1,1) - + /-0.125270693343174591D+1, 0.127889194935560226D+0/ - DATA - + YDATA( 4,1,1), XDATA( 4,1,1) - + /-0.996698267935287383D+0, 0.128615394085645676D+0/ - DATA - + YDATA( 5,1,1), XDATA( 5,1,1) - + /-0.104681033065801934D+1, 0.232544285655021667D+0/ - DATA - + YDATA( 6,1,1), XDATA( 6,1,1) - + /-0.146724952092847308D+1, 0.268151108026504516D+0/ - DATA - + YDATA( 7,1,1), XDATA( 7,1,1) - + /-0.123366891873487528D+1, 0.309041029810905456D+0/ - DATA - + YDATA( 8,1,1), XDATA( 8,1,1) - + /-0.165665097907185554D+1, 0.405991539210081099D+0/ - DATA - + YDATA( 9,1,1), XDATA( 9,1,1) - + /-0.168476460930907119D+1, 0.376611424833536147D+0/ - DATA - + YDATA(10,1,1), XDATA(10,1,1) - + /-0.198571971169224491D+1, 0.475875890851020811D+0/ - DATA - + YDATA(11,1,1), XDATA(11,1,1) - + /-0.195691696638051344D+1, 0.499246935397386550D+0/ - DATA - + YDATA(12,1,1), XDATA(12,1,1) - + /-0.211871342665769836D+1, 0.536615037024021147D+0/ - DATA - + YDATA(13,1,1), XDATA(13,1,1) - + /-0.268642932558671020D+1, 0.581830765902996060D+0/ - DATA - + YDATA(14,1,1), XDATA(14,1,1) - + /-0.281123260058024347D+1, 0.684512710422277446D+0/ - DATA - + YDATA(15,1,1), XDATA(15,1,1) - + /-0.328704486581785920D+1, 0.660219819694757458D+0/ - DATA - + YDATA(16,1,1), XDATA(16,1,1) - + /-0.423062993461887032D+1, 0.766990323960781092D+0/ - DATA - + YDATA(17,1,1), XDATA(17,1,1) - + /-0.512043906552226903D+1, 0.808270426690578456D+0/ - DATA - + YDATA(18,1,1), XDATA(18,1,1) - + /-0.731032616379005535D+1, 0.897410020083189004D+0/ - DATA - + YDATA(19,1,1), XDATA(19,1,1) - + /-0.109002759485608993D+2, 0.959199774116277687D+0/ - DATA - + YDATA(20,1,1), XDATA(20,1,1) - + /-0.251810238510370206D+2, 0.914675474762916558D+0/ - DATA - + YDATA(21,1,1), XDATA(21,1,1) - + /0.100123028650879944D+3, 0.997759691476821892D+0/ - DATA - + YDATA(22,1,1), XDATA(22,1,1) - + /0.168225085871915048D+2, 0.107136870384216308D+1/ - DATA - + YDATA(23,1,1), XDATA(23,1,1) - + /0.894830510866913009D+1, 0.108033321037888526D+1/ - DATA - + YDATA(24,1,1), XDATA(24,1,1) - + /0.645853815227747004D+1, 0.116064198672771453D+1/ - DATA - + YDATA(25,1,1), XDATA(25,1,1) - + /0.498218564760117328D+1, 0.119080889359116553D+1/ - DATA - + YDATA(26,1,1), XDATA(26,1,1) - + /0.382971664718710476D+1, 0.129418875187635420D+1/ - DATA - + YDATA(27,1,1), XDATA(27,1,1) - + /0.344116492497344184D+1, 0.135594148099422453D+1/ - DATA - + YDATA(28,1,1), XDATA(28,1,1) - + /0.276840496973858949D+1, 0.135302808716893195D+1/ - DATA - + YDATA(29,1,1), XDATA(29,1,1) - + /0.259521665196956666D+1, 0.137994666010141371D+1/ - DATA - + YDATA(30,1,1), XDATA(30,1,1) - + /0.205996022794557661D+1, 0.147630019545555113D+1/ - DATA - + YDATA(31,1,1), XDATA(31,1,1) - + /0.197939614345337836D+1, 0.153450708076357840D+1/ - DATA - + YDATA(32,1,1), XDATA(32,1,1) - + /0.156739340562905589D+1, 0.152805351451039313D+1/ - DATA - + YDATA(33,1,1), XDATA(33,1,1) - + /0.159032057073028366D+1, 0.157147316247224806D+1/ - DATA - + YDATA(34,1,1), XDATA(34,1,1) - + /0.173102268158937949D+1, 0.166649596005678175D+1/ - DATA - + YDATA(35,1,1), XDATA(35,1,1) - + /0.155512561664824758D+1, 0.166505665838718412D+1/ - DATA - + YDATA(36,1,1), XDATA(36,1,1) - + /0.149635994944133260D+1, 0.175214128553867338D+1/ - DATA - + YDATA(37,1,1), XDATA(37,1,1) - + /0.147487601463073568D+1, 0.180567992463707922D+1/ - DATA - + YDATA(38,1,1), XDATA(38,1,1) - + /0.117244575233306998D+1, 0.184624404296278952D+1/ - DATA - + YDATA(39,1,1), XDATA(39,1,1) - + /0.910931336069172580D+0, 0.195568727388978002D+1/ - DATA - + YDATA(40,1,1), XDATA(40,1,1) - + /0.126172980914513272D+1, 0.199326394036412237D+1/ - - DATA - + TDATA(2) - + /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 2'/ - DATA - + NDATA(2), MDATA(2), NPDATA(2), NQDATA(2) - + /50, 2, 3, 1/ - DATA - + (BDATA(K,2),K=1,3) - + /-1.0D+0, 1.0D+0, 1.0D+0/ - DATA - + YDATA( 1,1,2), XDATA( 1,1,2), XDATA( 1,2,2) - + /0.680832777217942900D+0, - + 0.625474598833994800D-1, 0.110179064209783100D+0/ - DATA - + YDATA( 2,1,2), XDATA( 2,1,2), XDATA( 2,2,2) - + /0.122183594595302200D+1, - + 0.202500343620642400D+0, -0.196140862891327600D-1/ - DATA - + YDATA( 3,1,2), XDATA( 3,1,2), XDATA( 3,2,2) - + /0.118958678734608200D+1, - + 0.164943738599876500D+0, 0.166514874750996600D+0/ - DATA - + YDATA( 4,1,2), XDATA( 4,1,2), XDATA( 4,2,2) - + /0.146982623764094600D+1, - + 0.304874137610506100D+0, 0.612908688041490500D-2/ - DATA - + YDATA( 5,1,2), XDATA( 5,1,2), XDATA( 5,2,2) - + /0.167775338189355300D+1, - + 0.532727445580665100D+0, 0.938248787552444600D-1/ - DATA - + YDATA( 6,1,2), XDATA( 6,1,2), XDATA( 6,2,2) - + /0.202485721906026200D+1, - + 0.508823707598910200D+0, 0.499605775020505400D-2/ - DATA - + YDATA( 7,1,2), XDATA( 7,1,2), XDATA( 7,2,2) - + /0.258912851935938800D+1, - + 0.704227041878554000D+0, 0.819354849092326200D-1/ - DATA - + YDATA( 8,1,2), XDATA( 8,1,2), XDATA( 8,2,2) - + /0.366894203254154800D+1, - + 0.592077736111512000D+0, 0.127113960672389100D-1/ - DATA - + YDATA( 9,1,2), XDATA( 9,1,2), XDATA( 9,2,2) - + /0.574609583351347300D+1, - + 0.104940945646421600D+1, 0.258095243658316100D-1/ - DATA - + YDATA(10,1,2), XDATA(10,1,2), XDATA(10,2,2) - + /0.127676424026489300D+2, - + 0.979382517558619200D+0, 0.124280755181027900D+0/ - DATA - + YDATA(11,1,2), XDATA(11,1,2), XDATA(11,2,2) - + /0.123473079693623100D+1, - + 0.637870453165538700D-1, 0.304856401137196400D+0/ - DATA - + YDATA(12,1,2), XDATA(12,1,2), XDATA(12,2,2) - + /0.142256120864082800D+1, - + 0.176123312906025700D+0, 0.262387028078896900D+0/ - DATA - + YDATA(13,1,2), XDATA(13,1,2), XDATA(13,2,2) - + /0.169889534013024700D+1, - + 0.310965082300263000D+0, 0.226430765474758800D+0/ - DATA - + YDATA(14,1,2), XDATA(14,1,2), XDATA(14,2,2) - + /0.173485577901204400D+1, - + 0.311394269116782100D+0, 0.271375840410281800D+0/ - DATA - + YDATA(15,1,2), XDATA(15,1,2), XDATA(15,2,2) - + /0.277761263972834600D+1, - + 0.447076126190612500D+0, 0.255000858902618300D+0/ - DATA - + YDATA(16,1,2), XDATA(16,1,2), XDATA(16,2,2) - + /0.339163324662617300D+1, - + 0.384786230998211100D+0, 0.154958003178364000D+0/ - DATA - + YDATA(17,1,2), XDATA(17,1,2), XDATA(17,2,2) - + /0.589615137312147500D+1, - + 0.649093176450780500D+0, 0.258301685463773200D+0/ - DATA - + YDATA(18,1,2), XDATA(18,1,2), XDATA(18,2,2) - + /0.124415625214576800D+2, - + 0.685612005372525500D+0, 0.107391260603228600D+0/ - DATA - + YDATA(19,1,2), XDATA(19,1,2), XDATA(19,2,2) - + /-0.498491739153861600D+2, - + 0.968747139425088400D+0, 0.151932526135740700D+0/ - DATA - + YDATA(20,1,2), XDATA(20,1,2), XDATA(20,2,2) - + /-0.832795509000618600D+1, - + 0.869789367989532900D+0, 0.625507500586400000D-1/ - DATA - + YDATA(21,1,2), XDATA(21,1,2), XDATA(21,2,2) - + /0.184934617774239900D+1, - + -0.465309930332736600D-2, 0.546795662595375200D+0/ - DATA - + YDATA(22,1,2), XDATA(22,1,2), XDATA(22,2,2) - + /0.175192979176839200D+1, - + 0.604753397196646000D-2, 0.230905749473922700D+0/ - DATA - + YDATA(23,1,2), XDATA(23,1,2), XDATA(23,2,2) - + /0.253949381238535800D+1, - + 0.239418809621756000D+0, 0.190752069681170700D+0/ - DATA - + YDATA(24,1,2), XDATA(24,1,2), XDATA(24,2,2) - + /0.373500774928501700D+1, - + 0.456662468911699800D+0, 0.328870615170984400D+0/ - DATA - + YDATA(25,1,2), XDATA(25,1,2), XDATA(25,2,2) - + /0.548408128950331000D+1, - + 0.371115320522079500D+0, 0.439978556640660500D+0/ - DATA - + YDATA(26,1,2), XDATA(26,1,2), XDATA(26,2,2) - + /0.125256880521774300D+2, - + 0.586442107042503000D+0, 0.490689043752286700D+0/ - DATA - + YDATA(27,1,2), XDATA(27,1,2), XDATA(27,2,2) - + /-0.493587797164916600D+2, - + 0.579796274973298000D+0, 0.521860998203383100D+0/ - DATA - + YDATA(28,1,2), XDATA(28,1,2), XDATA(28,2,2) - + /-0.801158974965412700D+1, - + 0.805008094903899900D+0, 0.292283538955391600D+0/ - DATA - + YDATA(29,1,2), XDATA(29,1,2), XDATA(29,2,2) - + /-0.437399487061934100D+1, - + 0.637242340835710000D+0, 0.402261740352486000D+0/ - DATA - + YDATA(30,1,2), XDATA(30,1,2), XDATA(30,2,2) - + /-0.297800103425979600D+1, - + 0.982132817936118700D+0, 0.392546836419047000D+0/ - DATA - + YDATA(31,1,2), XDATA(31,1,2), XDATA(31,2,2) - + /0.271811057454661300D+1, - + -0.223515657121262700D-1, 0.650479019708978800D+0/ - DATA - + YDATA(32,1,2), XDATA(32,1,2), XDATA(32,2,2) - + /0.377035865613392400D+1, - + 0.136081427545033600D+0, 0.753020101897661800D+0/ - DATA - + YDATA(33,1,2), XDATA(33,1,2), XDATA(33,2,2) - + /0.560111053917143100D+1, - + 0.145367053019870600D+0, 0.611153532003093100D+0/ - DATA - + YDATA(34,1,2), XDATA(34,1,2), XDATA(34,2,2) - + /0.128152376174926800D+2, - + 0.308221919576435500D+0, 0.455217283290423900D+0/ - DATA - + YDATA(35,1,2), XDATA(35,1,2), XDATA(35,2,2) - + /-0.498709177732467200D+2, - + 0.432658769133528300D+0, 0.678607663414113000D+0/ - DATA - + YDATA(36,1,2), XDATA(36,1,2), XDATA(36,2,2) - + /-0.815797696908314300D+1, - + 0.477785501079980300D+0, 0.536178207572157000D+0/ - DATA - + YDATA(37,1,2), XDATA(37,1,2), XDATA(37,2,2) - + /-0.440240491195158600D+1, - + 0.727986827616619000D+0, 0.668497920573493900D+0/ - DATA - + YDATA(38,1,2), XDATA(38,1,2), XDATA(38,2,2) - + /-0.276723957061767500D+1, - + 0.745950385588265100D+0, 0.786077589007263700D+0/ - DATA - + YDATA(39,1,2), XDATA(39,1,2), XDATA(39,2,2) - + /-0.223203667288734800D+1, - + 0.732537503527113500D+0, 0.582625164046828400D+0/ - DATA - + YDATA(40,1,2), XDATA(40,1,2), XDATA(40,2,2) - + /-0.169728270310622000D+1, - + 0.967352361433846300D+0, 0.460779396016832800D+0/ - DATA - + YDATA(41,1,2), XDATA(41,1,2), XDATA(41,2,2) - + /0.551015652153227000D+1, - + 0.129761784310891100D-1, 0.700009537931860000D+0/ - DATA - + YDATA(42,1,2), XDATA(42,1,2), XDATA(42,2,2) - + /0.128036180496215800D+2, - + 0.170163243950629700D+0, 0.853131830764348700D+0/ - DATA - + YDATA(43,1,2), XDATA(43,1,2), XDATA(43,2,2) - + /-0.498257683396339000D+2, - + 0.162768461906274000D+0, 0.865315129048175000D+0/ - DATA - + YDATA(44,1,2), XDATA(44,1,2), XDATA(44,2,2) - + /-0.877334550221761900D+1, - + 0.222914807946165800D+0, 0.797511758502094500D+0/ - DATA - + YDATA(45,1,2), XDATA(45,1,2), XDATA(45,2,2) - + /-0.453820192156867600D+1, - + 0.402910095604624900D+0, 0.761492958727023100D+0/ - DATA - + YDATA(46,1,2), XDATA(46,1,2), XDATA(46,2,2) - + /-0.297499315738677900D+1, - + 0.233770812593443200D+0, 0.896000095844223500D+0/ - DATA - + YDATA(47,1,2), XDATA(47,1,2), XDATA(47,2,2) - + /-0.212743255978538900D+1, - + 0.646528693486914700D+0, 0.968574333700755700D+0/ - DATA - + YDATA(48,1,2), XDATA(48,1,2), XDATA(48,2,2) - + /-0.209703205365401000D+1, - + 0.802811658568969400D+0, 0.904866450476711600D+0/ - DATA - + YDATA(49,1,2), XDATA(49,1,2), XDATA(49,2,2) - + /-0.155287292042086200D+1, - + 0.837137859891222900D+0, 0.835684424990021900D+0/ - DATA - + YDATA(50,1,2), XDATA(50,1,2), XDATA(50,2,2) - + /-0.161356673770480700D+1, - + 0.103165980756526600D+1, 0.793902191912346100D+0/ - - DATA - + TDATA(3) - + /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3'/ - DATA - + NDATA(3), MDATA(3), NPDATA(3), NQDATA(3) - + /44, 1, 9, 1/ - DATA - + (BDATA(K,3),K=1,9) - + /0.281887509408440189D-5, - + -0.231290549212363845D-2, 0.583035555572801965D+1, - + 0.000000000000000000D+0, 0.406910776203121026D+8, - + 0.138001105225000000D-2, 0.596038513209999999D-1, - + 0.670582099359999998D+1, 0.106994410000000000D+10/ - DATA - + YDATA( 1,1,3), XDATA( 1,1,3) - + /0.988227696721327788D+0, 0.25D-8/ - DATA - + YDATA( 2,1,3), XDATA( 2,1,3) - + /0.988268083998559958D+0, 0.64D-8/ - DATA - + YDATA( 3,1,3), XDATA( 3,1,3) - + /0.988341022958438831D+0, 1.0D-8/ - DATA - + YDATA( 4,1,3), XDATA( 4,1,3) - + /0.988380557606306446D+0, 0.9D-7/ - DATA - + YDATA( 5,1,3), XDATA( 5,1,3) - + /0.988275062411751338D+0, 1.0D-6/ - DATA - + YDATA( 6,1,3), XDATA( 6,1,3) - + /0.988326680176446987D+0, 0.4D-5/ - DATA - + YDATA( 7,1,3), XDATA( 7,1,3) - + /0.988306058860433439D+0, 0.9D-5/ - DATA - + YDATA( 8,1,3), XDATA( 8,1,3) - + /0.988292880079125555D+0, 0.16D-4/ - DATA - + YDATA( 9,1,3), XDATA( 9,1,3) - + /0.988305279259496905D+0, 0.36D-4/ - DATA - + YDATA(10,1,3), XDATA(10,1,3) - + /0.988278142019574202D+0, 0.64D-4/ - DATA - + YDATA(11,1,3), XDATA(11,1,3) - + /0.988224953369819946D+0, 1.0D-4/ - DATA - + YDATA(12,1,3), XDATA(12,1,3) - + /0.988111989169778223D+0, 0.144D-3/ - DATA - + YDATA(13,1,3), XDATA(13,1,3) - + /0.988045627103840613D+0, 0.225D-3/ - DATA - + YDATA(14,1,3), XDATA(14,1,3) - + /0.987913715667047655D+0, 0.400D-3/ - DATA - + YDATA(15,1,3), XDATA(15,1,3) - + /0.987841994238525678D+0, 0.625D-3/ - DATA - + YDATA(16,1,3), XDATA(16,1,3) - + /0.987638450432434270D+0, 0.900D-3/ - DATA - + YDATA(17,1,3), XDATA(17,1,3) - + /0.987587364331771395D+0, 0.1225D-2/ - DATA - + YDATA(18,1,3), XDATA(18,1,3) - + /0.987576264149633684D+0, 0.1600D-2/ - DATA - + YDATA(19,1,3), XDATA(19,1,3) - + /0.987539209110983643D+0, 0.2025D-2/ - DATA - + YDATA(20,1,3), XDATA(20,1,3) - + /0.987621143807705698D+0, 0.25D-2/ - DATA - + YDATA(21,1,3), XDATA(21,1,3) - + /0.988023229785526217D+0, 0.36D-2/ - DATA - + YDATA(22,1,3), XDATA(22,1,3) - + /0.988558376710994197D+0, 0.49D-2/ - DATA - + YDATA(23,1,3), XDATA(23,1,3) - + /0.989304775352439885D+0, 0.64D-2/ - DATA - + YDATA(24,1,3), XDATA(24,1,3) - + /0.990210452265710472D+0, 0.81D-2/ - DATA - + YDATA(25,1,3), XDATA(25,1,3) - + /0.991095950592263900D+0, 1.00D-2/ - DATA - + YDATA(26,1,3), XDATA(26,1,3) - + /0.991475677297119272D+0, 0.11025D-1/ - DATA - + YDATA(27,1,3), XDATA(27,1,3) - + /0.991901306250746771D+0, 0.12100D-1/ - DATA - + YDATA(28,1,3), XDATA(28,1,3) - + /0.992619222425303263D+0, 0.14400D-1/ - DATA - + YDATA(29,1,3), XDATA(29,1,3) - + /0.993617037631973475D+0, 0.16900D-1/ - DATA - + YDATA(30,1,3), XDATA(30,1,3) - + /0.994727321698030676D+0, 0.19600D-1/ - DATA - + YDATA(31,1,3), XDATA(31,1,3) - + /0.996523114720326189D+0, 0.25600D-1/ - DATA - + YDATA(32,1,3), XDATA(32,1,3) - + /0.998036909563764020D+0, 0.32400D-1/ - DATA - + YDATA(33,1,3), XDATA(33,1,3) - + /0.999151968626971372D+0, 0.40000D-1/ - DATA - + YDATA(34,1,3), XDATA(34,1,3) - + /0.100017083706131769D+1, 0.50625D-1/ - DATA - + YDATA(35,1,3), XDATA(35,1,3) - + /0.100110046382923523D+1, 0.75625D-1/ - DATA - + YDATA(36,1,3), XDATA(36,1,3) - + /0.100059103180404652D+1, 0.12250D+0/ - DATA - + YDATA(37,1,3), XDATA(37,1,3) - + /0.999211829791257561D+0, 0.16000D+0/ - DATA - + YDATA(38,1,3), XDATA(38,1,3) - + /0.994711451526761862D+0, 0.25000D+0/ - DATA - + YDATA(39,1,3), XDATA(39,1,3) - + /0.989844132928847109D+0, 0.33640D+0/ - DATA - + YDATA(40,1,3), XDATA(40,1,3) - + /0.987234104554490439D+0, 0.38440D+0/ - DATA - + YDATA(41,1,3), XDATA(41,1,3) - + /0.980928240178404887D+0, 0.49D+0/ - DATA - + YDATA(42,1,3), XDATA(42,1,3) - + /0.970888680366055576D+0, 0.64D+0/ - DATA - + YDATA(43,1,3), XDATA(43,1,3) - + /0.960043769857327398D+0, 0.81D+0/ - DATA - + YDATA(44,1,3), XDATA(44,1,3) - + /0.947277159259551068D+0, 1.00D+0/ - - DATA - + TDATA(4) - + /' HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188'/ - DATA - + NDATA(4), MDATA(4), NPDATA(4), NQDATA(4) - + /13, 2, 3, 1/ - DATA - + (BDATA(K,4),K=1,3) - + /3.0D+0, 3.0D+0, -0.5D+0/ - DATA - + YDATA( 1,1,4), XDATA( 1,1,4), XDATA( 1,2,4) - + /2.93D+0, 0.0D+0, 0.0D+0/ - DATA - + YDATA( 2,1,4), XDATA( 2,1,4), XDATA( 2,2,4) - + /1.95D+0, 0.0D+0, 1.0D+0/ - DATA - + YDATA( 3,1,4), XDATA( 3,1,4), XDATA( 3,2,4) - + /0.81D+0, 0.0D+0, 2.0D+0/ - DATA - + YDATA( 4,1,4), XDATA( 4,1,4), XDATA( 4,2,4) - + /0.58D+0, 0.0D+0, 3.0D+0/ - DATA - + YDATA( 5,1,4), XDATA( 5,1,4), XDATA( 5,2,4) - + /5.90D+0, 1.0D+0, 0.0D+0/ - DATA - + YDATA( 6,1,4), XDATA( 6,1,4), XDATA( 6,2,4) - + /4.74D+0, 1.0D+0, 1.0D+0/ - DATA - + YDATA( 7,1,4), XDATA( 7,1,4), XDATA( 7,2,4) - + /4.18D+0, 1.0D+0, 2.0D+0/ - DATA - + YDATA( 8,1,4), XDATA( 8,1,4), XDATA( 8,2,4) - + /4.05D+0, 1.0D+0, 2.0D+0/ - DATA - + YDATA( 9,1,4), XDATA( 9,1,4), XDATA( 9,2,4) - + /9.03D+0, 2.0D+0, 0.0D+0/ - DATA - + YDATA(10,1,4), XDATA(10,1,4), XDATA(10,2,4) - + /7.85D+0, 2.0D+0, 1.0D+0/ - DATA - + YDATA(11,1,4), XDATA(11,1,4), XDATA(11,2,4) - + /7.22D+0, 2.0D+0, 2.0D+0/ - DATA - + YDATA(12,1,4), XDATA(12,1,4), XDATA(12,2,4) - + /8.50D+0, 2.5D+0, 2.0D+0/ - DATA - + YDATA(13,1,4), XDATA(13,1,4), XDATA(13,2,4) - + /9.81D+0, 2.9D+0, 1.8D+0/ - - DATA - + TDATA(5) - + /' DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522'/ - DATA - + NDATA(5), MDATA(5), NPDATA(5), NQDATA(5) - + /8, 2, 2, 1/ - DATA - + (BDATA(K,5),K=1,2) - + /0.01155D+0, 5000.0D+0/ - DATA - + YDATA(1,1,5), XDATA(1,1,5), XDATA(1,2,5) - + /0.912D+0, 109.0D+0, 600.0D+0/ - DATA - + YDATA(2,1,5), XDATA(2,1,5), XDATA(2,2,5) - + /0.382D+0, 65.0D+0, 640.0D+0/ - DATA - + YDATA(3,1,5), XDATA(3,1,5), XDATA(3,2,5) - + /0.397D+0, 1180.0D+0, 600.0D+0/ - DATA - + YDATA(4,1,5), XDATA(4,1,5), XDATA(4,2,5) - + /0.376D+0, 66.0D+0, 640.0D+0/ - DATA - + YDATA(5,1,5), XDATA(5,1,5), XDATA(5,2,5) - + /0.342D+0, 1270.0D+0, 600.0D+0/ - DATA - + YDATA(6,1,5), XDATA(6,1,5), XDATA(6,2,5) - + /0.358D+0, 69.0D+0, 640.0D+0/ - DATA - + YDATA(7,1,5), XDATA(7,1,5), XDATA(7,2,5) - + /0.348D+0, 1230.0D+0, 600.0D+0/ - DATA - + YDATA(8,1,5), XDATA(8,1,5), XDATA(8,2,5) - + /0.376D+0, 68.0D+0, 640.0D+0/ - - DATA - + TDATA(6) - + /' POWELL AND MACDONALD, 1972, TABLES 7 AND 8, PAGES 153-154'/ - DATA - + NDATA(6), MDATA(6), NPDATA(6), NQDATA(6) - + /14, 1, 3, 1/ - DATA - + (BDATA(K,6),K=1,3) - + /25.0D+0, 30.0D+0, 6.0D+0/ - DATA - + YDATA( 1,1,6), XDATA( 1,1,6) - + /26.38D+0, 1.0D+0/ - DATA - + YDATA( 2,1,6), XDATA( 2,1,6) - + /25.79D+0, 2.0D+0/ - DATA - + YDATA( 3,1,6), XDATA( 3,1,6) - + /25.29D+0, 3.0D+0/ - DATA - + YDATA( 4,1,6), XDATA( 4,1,6) - + /24.86D+0, 4.0D+0/ - DATA - + YDATA( 5,1,6), XDATA( 5,1,6) - + /24.46D+0, 5.0D+0/ - DATA - + YDATA( 6,1,6), XDATA( 6,1,6) - + /24.10D+0, 6.0D+0/ - DATA - + YDATA( 7,1,6), XDATA( 7,1,6) - + /23.78D+0, 7.0D+0/ - DATA - + YDATA( 8,1,6), XDATA( 8,1,6) - + /23.50D+0, 8.0D+0/ - DATA - + YDATA( 9,1,6), XDATA( 9,1,6) - + /23.24D+0, 9.0D+0/ - DATA - + YDATA(10,1,6), XDATA(10,1,6) - + /23.00D+0, 10.0D+0/ - DATA - + YDATA(11,1,6), XDATA(11,1,6) - + /22.78D+0, 11.0D+0/ - DATA - + YDATA(12,1,6), XDATA(12,1,6) - + /22.58D+0, 12.0D+0/ - DATA - + YDATA(13,1,6), XDATA(13,1,6) - + /22.39D+0, 13.0D+0/ - DATA - + YDATA(14,1,6), XDATA(14,1,6) - + /22.22D+0, 14.0D+0/ - - DATA - + TDATA(7) - + /' FULLER, 1987, TABLE 3.2.10, PAGES 244-245'/ - DATA - + NDATA(7), MDATA(7), NPDATA(7), NQDATA(7) - + /20, 2, 5, 1/ - DATA - + (BDATA(K,7),K=1,5) - + /-1.0D+0, -3.0D+0, 0.09D+0, 0.02D+0, 0.08D+0/ - DATA - + YDATA( 1,1,7), XDATA( 1,1,7), XDATA( 1,2,7) - + /0.0D+0, 0.50D+0, -0.12D+0/ - DATA - + YDATA( 2,1,7), XDATA( 2,1,7), XDATA( 2,2,7) - + /0.0D+0, 1.20D+0, -0.60D+0/ - DATA - + YDATA( 3,1,7), XDATA( 3,1,7), XDATA( 3,2,7) - + /0.0D+0, 1.60D+0, -1.00D+0/ - DATA - + YDATA( 4,1,7), XDATA( 4,1,7), XDATA( 4,2,7) - + /0.0D+0, 1.86D+0, -1.40D+0/ - DATA - + YDATA( 5,1,7), XDATA( 5,1,7), XDATA( 5,2,7) - + /0.0D+0, 2.12D+0, -2.54D+0/ - DATA - + YDATA( 6,1,7), XDATA( 6,1,7), XDATA( 6,2,7) - + /0.0D+0, 2.36D+0, -3.36D+0/ - DATA - + YDATA( 7,1,7), XDATA( 7,1,7), XDATA( 7,2,7) - + /0.0D+0, 2.44D+0, -4.00D+0/ - DATA - + YDATA( 8,1,7), XDATA( 8,1,7), XDATA( 8,2,7) - + /0.0D+0, 2.36D+0, -4.75D+0/ - DATA - + YDATA( 9,1,7), XDATA( 9,1,7), XDATA( 9,2,7) - + /0.0D+0, 2.06D+0, -5.25D+0/ - DATA - + YDATA(10,1,7), XDATA(10,1,7), XDATA(10,2,7) - + /0.0D+0, 1.74D+0, -5.64D+0/ - DATA - + YDATA(11,1,7), XDATA(11,1,7), XDATA(11,2,7) - + /0.0D+0, 1.34D+0, -5.97D+0/ - DATA - + YDATA(12,1,7), XDATA(12,1,7), XDATA(12,2,7) - + /0.0D+0, 0.90D+0, -6.32D+0/ - DATA - + YDATA(13,1,7), XDATA(13,1,7), XDATA(13,2,7) - + /0.0D+0, -0.28D+0, -6.44D+0/ - DATA - + YDATA(14,1,7), XDATA(14,1,7), XDATA(14,2,7) - + /0.0D+0, -0.78D+0, -6.44D+0/ - DATA - + YDATA(15,1,7), XDATA(15,1,7), XDATA(15,2,7) - + /0.0D+0, -1.36D+0, -6.41D+0/ - DATA - + YDATA(16,1,7), XDATA(16,1,7), XDATA(16,2,7) - + /0.0D+0, -1.90D+0, -6.25D+0/ - DATA - + YDATA(17,1,7), XDATA(17,1,7), XDATA(17,2,7) - + /0.0D+0, -2.50D+0, -5.88D+0/ - DATA - + YDATA(18,1,7), XDATA(18,1,7), XDATA(18,2,7) - + /0.0D+0, -2.88D+0, -5.50D+0/ - DATA - + YDATA(19,1,7), XDATA(19,1,7), XDATA(19,2,7) - + /0.0D+0, -3.18D+0, -5.24D+0/ - DATA - + YDATA(20,1,7), XDATA(20,1,7), XDATA(20,2,7) - + /0.0D+0, -3.44D+0, -4.86D+0/ - - DATA - + TDATA(8) - + /' BATES AND WATTS, 1988, TABLE A1.13, PAGES 280-281'/ - DATA - + NDATA(8), MDATA(8), NPDATA(8), NQDATA(8) - + /23, 1, 5, 2/ - DATA - + (BDATA(K,8),K=1,5) - + /4.0D+0, 2.0D+0, 7.0D+0, 0.40D+0, 0.50D+0/ - DATA - + YDATA( 1,1,8), YDATA( 1,2,8), XDATA( 1,1,8) - + /4.220D+0, 0.136D+0, 30.0D+0/ - DATA - + YDATA( 2,1,8), YDATA( 2,2,8), XDATA( 2,1,8) - + /4.167D+0, 0.167D+0, 50.0D+0/ - DATA - + YDATA( 3,1,8), YDATA( 3,2,8), XDATA( 3,1,8) - + /4.132D+0, 0.188D+0, 70.0D+0/ - DATA - + YDATA( 4,1,8), YDATA( 4,2,8), XDATA( 4,1,8) - + /4.038D+0, 0.212D+0, 100.0D+0/ - DATA - + YDATA( 5,1,8), YDATA( 5,2,8), XDATA( 5,1,8) - + /4.019D+0, 0.236D+0, 150.0D+0/ - DATA - + YDATA( 6,1,8), YDATA( 6,2,8), XDATA( 6,1,8) - + /3.956D+0, 0.257D+0, 200.0D+0/ - DATA - + YDATA( 7,1,8), YDATA( 7,2,8), XDATA( 7,1,8) - + /3.884D+0, 0.276D+0, 300.0D+0/ - DATA - + YDATA( 8,1,8), YDATA( 8,2,8), XDATA( 8,1,8) - + /3.784D+0, 0.297D+0, 500.0D+0/ - DATA - + YDATA( 9,1,8), YDATA( 9,2,8), XDATA( 9,1,8) - + /3.713D+0, 0.309D+0, 700.0D+0/ - DATA - + YDATA(10,1,8), YDATA(10,2,8), XDATA(10,1,8) - + /3.633D+0, 0.311D+0, 1000.0D+0/ - DATA - + YDATA(11,1,8), YDATA(11,2,8), XDATA(11,1,8) - + /3.540D+0, 0.314D+0, 1500.0D+0/ - DATA - + YDATA(12,1,8), YDATA(12,2,8), XDATA(12,1,8) - + /3.433D+0, 0.311D+0, 2000.0D+0/ - DATA - + YDATA(13,1,8), YDATA(13,2,8), XDATA(13,1,8) - + /3.358D+0, 0.305D+0, 3000.0D+0/ - DATA - + YDATA(14,1,8), YDATA(14,2,8), XDATA(14,1,8) - + /3.258D+0, 0.289D+0, 5000.0D+0/ - DATA - + YDATA(15,1,8), YDATA(15,2,8), XDATA(15,1,8) - + /3.193D+0, 0.277D+0, 7000.0D+0/ - DATA - + YDATA(16,1,8), YDATA(16,2,8), XDATA(16,1,8) - + /3.128D+0, 0.255D+0, 10000.0D+0/ - DATA - + YDATA(17,1,8), YDATA(17,2,8), XDATA(17,1,8) - + /3.059D+0, 0.240D+0, 15000.0D+0/ - DATA - + YDATA(18,1,8), YDATA(18,2,8), XDATA(18,1,8) - + /2.984D+0, 0.218D+0, 20000.0D+0/ - DATA - + YDATA(19,1,8), YDATA(19,2,8), XDATA(19,1,8) - + /2.934D+0, 0.202D+0, 30000.0D+0/ - DATA - + YDATA(20,1,8), YDATA(20,2,8), XDATA(20,1,8) - + /2.876D+0, 0.182D+0, 50000.0D+0/ - DATA - + YDATA(21,1,8), YDATA(21,2,8), XDATA(21,1,8) - + /2.838D+0, 0.168D+0, 70000.0D+0/ - DATA - + YDATA(22,1,8), YDATA(22,2,8), XDATA(22,1,8) - + /2.798D+0, 0.153D+0, 100000.0D+0/ - DATA - + YDATA(23,1,8), YDATA(23,2,8), XDATA(23,1,8) - + /2.759D+0, 0.139D+0, 150000.0D+0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BDATA: THE FUNCTION PARAMETER FOR EACH DATA SET. -C BETA: THE FUNCTION PARAMETERS. -C I: AN INDEXING VARIABLE. -C J: AN INDEXING VARIABLE. -C L: AN INDEXING VARIABLE. -C LDX: THE LEADING DIMENSION OF ARRAY X. -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C MDATA: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE -C IN EACH DATA SET. -C N: THE NUMBER OF OBSERVATIONS. -C NDATA: THE NUMBER OF OBSERVATIONS PER DATA SET. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NPDATA: THE NUMBER OF FUNCTION PARAMETERS IN EACH DATA SET. -C NQDATA: THE NUMBER OF RESPONSES PER OBSERVATION IN EACH DATA SET. -C SETNO: THE NUMBER OF THE DATA SET BEING ANALYZED. -C TDATA: THE REFERENCE FOR THE EACH OF THE DATA SETS. -C TITLE: THE REFERENCE FOR THE DATA SET BEING ANALYZED. -C X: THE EXPLANATORY VARIABLES. -C XDATA: THE EXPLANATORY VARIABLES FOR EACH DATA SET. -C Y: THE RESPONSE VARIABLE. -C YDATA: THE RESPONSE VARIABLES FOR EACH DATA SET. - - -C***FIRST EXECUTABLE STATEMENT DODRXD - - - TITLE = TDATA(SETNO) - - N = NDATA(SETNO) - M = MDATA(SETNO) - NP = NPDATA(SETNO) - NQ = NQDATA(SETNO) - - DO 20 L=1,NQ - DO 10 I=1,N - Y(I,L) = YDATA(I,L,SETNO) - 10 CONTINUE - 20 CONTINUE - - DO 40 J=1,M - DO 30 I=1,N - X(I,J) = XDATA(I,J,SETNO) - 30 CONTINUE - 40 CONTINUE - - DO 50 K=1,NP - BETA(K) = BDATA(K,SETNO) - 50 CONTINUE - - RETURN - - END -*DODRXF - SUBROUTINE DODRXF - + (N,M,NP,NQ, - + LDN,LDM,LDNP, - + BETA,XPLUSD, - + IFIXB,IFIXX,LDIFX, - + IDEVAL,F,FJACB,FJACD, - + ISTOP) -C***BEGIN PROLOGUE DODRXF -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 860529 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE COMPUTE JACOBIAN MATRICIES FOR ODRPACK EXERCISER -C***END PROLOGUE DODRXF - -C...SCALAR ARGUMENTS - INTEGER - + IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ - -C...ARRAY ARGUMENTS - DOUBLE PRECISION - + BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ), - + XPLUSD(LDN,M) - INTEGER - + IFIXB(NP),IFIXX(LDIFX,M) - -C...SCALARS IN COMMON - INTEGER - + SETNO - -C...LOCAL SCALARS - DOUBLE PRECISION - + CTHETA,FAC1,FAC2,FAC3,FAC4,FREQ, - + OMEGA,ONE,PHI,PI,R,STHETA,THETA,ZERO - INTEGER - + I,J,K - -C...INTRINSIC FUNCTIONS - INTRINSIC - + ATAN2,COS,EXP,SIN,SQRT - -C...COMMON BLOCKS - COMMON /SETID/SETNO - -C...DATA STATEMENTS - DATA - + ZERO,ONE - + /0.0D0,1.0D0/ - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C BETA: CURRENT VALUES OF PARAMETERS -C F: PREDICTED FUNCTION VALUES -C FAC1: A FACTORS OR TERMS USED IN COMPUTING THE JACOBIANS. -C FAC2: A FACTORS OR TERMS USED IN COMPUTING THE JACOBIANS. -C FAC3: A FACTORS OR TERMS USED IN COMPUTING THE JACOBIANS. -C FAC4: A FACTORS OR TERMS USED IN COMPUTING THE JACOBIANS. -C FJACB: JACOBIAN WITH RESPECT TO BETA -C FJACD: JACOBIAN WITH RESPECT TO ERRORS DELTA -C IDEVAL: INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED -C IFIXB: INDICATORS FOR "FIXING" PARAMETERS (BETA) -C IFIXX: INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) -C LDIFX: LEADING DIMENSION OF ARRAY IFIXX -C ISTOP: STOPPING CONDITION, WHERE -C 0 MEANS CURRENT BETA AND X+DELTA WERE -C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY -C 1 MEANS CURRENT BETA AND X+DELTA ARE -C NOT ACCEPTABLE; ODRPACK SHOULD SELECT -C VALUES CLOSER TO MOST RECENTLY USED VALUES -C -1 MEANS CURRENT BETA AND X+DELTA ARE -C NOT ACCEPTABLE; ODRPACK SHOULD STOP -C LDN: LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N -C LDM: LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M -C LDNP: LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP -C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. -C N: THE NUMBER OF OBSERVATIONS. -C NP: THE NUMBER OF FUNCTION PARAMETERS. -C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. -C ONE: THE VALUE 1.0D0. -C SETNO: THE NUMBER OF THE DATA SET BEING ANALYZED. -C XPLUSD: CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA -C ZERO: THE VALUE 0.0D0. - - -C***FIRST EXECUTABLE STATEMENT DODRXF - - - IF (SETNO.EQ.1) THEN - -C SETNO. 1: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1 - - IF (BETA(1).LE.1.01D0) THEN - ISTOP = 0 - - IF (MOD(IDEVAL,10).NE.0) THEN - DO 100 I=1,N - F(I,1) = BETA(1)/(XPLUSD(I,1)-BETA(2)) - 100 CONTINUE - END IF - - IF (MOD(IDEVAL/10,10).NE.0) THEN - DO 110 I=1,N - FJACB(I,1,1) = ONE/(XPLUSD(I,1)-BETA(2)) - FJACB(I,2,1) = BETA(1)*(XPLUSD(I,1)-BETA(2))**(-2) - 110 CONTINUE - END IF - - IF (MOD(IDEVAL/100,10).NE.0) THEN - DO 120 I=1,N - FJACD(I,1,1) = -BETA(1)*(XPLUSD(I,1)-BETA(2))**(-2) - 120 CONTINUE - END IF - - ELSE - ISTOP = 1 - END IF - - ELSE IF (SETNO.EQ.2) THEN - -C SETNO. 2: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 2 - - ISTOP = 0 - - DO 200 I=1,N - FAC1 = (BETA(2)*XPLUSD(I,1)+BETA(3)*XPLUSD(I,2)-ONE) - - IF (MOD(IDEVAL,10).NE.0) THEN - F(I,1) = BETA(1)/FAC1 - END IF - - IF (MOD(IDEVAL/10,10).NE.0) THEN - FJACB(I,1,1) = ONE/FAC1 - FJACB(I,2,1) = -BETA(1)*(FAC1**(-2))*XPLUSD(I,1) - FJACB(I,3,1) = -BETA(1)*(FAC1**(-2))*XPLUSD(I,2) - END IF - - IF (MOD(IDEVAL/100,10).NE.0) THEN - FJACD(I,1,1) = -BETA(1)*(FAC1**(-2))*BETA(2) - FJACD(I,2,1) = -BETA(1)*(FAC1**(-2))*BETA(3) - END IF - 200 CONTINUE - - ELSE IF (SETNO.EQ.3) THEN - -C SETNO. 3: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3 - - ISTOP = 0 - - IF (MOD(IDEVAL,10).NE.0) THEN - DO 310 I=1,N - F(I,1) = ZERO - DO 300 J=1,4 - F(I,1) = F(I,1) + BETA(J)/(XPLUSD(I,1)+BETA(J+5)) - 300 CONTINUE - F(I,1) = F(I,1) + BETA(5) - 310 CONTINUE - END IF - - IF (MOD(IDEVAL/10,10).NE.0) THEN - DO 330 I=1,N - FJACB(I,5,1) = ONE - DO 320 K=1,4 - FJACB(I,K,1) = ONE/(XPLUSD(I,1)+BETA(K+5)) - FJACB(I,K+5,1) = -BETA(K)* - + (XPLUSD(I,1)+BETA(K+5))**(-2) - 320 CONTINUE - 330 CONTINUE - END IF - - IF (MOD(IDEVAL/100,10).NE.0) THEN - DO 350 I=1,N - FJACD(I,1,1) = ZERO - DO 340 K=4,1,-1 - FJACD(I,1,1) = FJACD(I,1,1) - - + BETA(K)*(XPLUSD(I,1)+BETA(K+5))**(-2) - 340 CONTINUE - 350 CONTINUE - END IF - - ELSE IF (SETNO.EQ.4) THEN - -C SETNO. 4: HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188 - - ISTOP = 0 - - IF (MOD(IDEVAL,10).NE.0) THEN - DO 400 I = 1, N - F(I,1) = BETA(1)*XPLUSD(I,1) + - + BETA(2)*EXP(BETA(3)*XPLUSD(I,2)) - 400 CONTINUE - END IF - - IF (MOD(IDEVAL/10,10).NE.0) THEN - DO 410 I=1,N - FJACB(I,1,1) = XPLUSD(I,1) - FJACB(I,2,1) = EXP(BETA(3)*XPLUSD(I,2)) - FJACB(I,3,1) = BETA(2)* - + EXP(BETA(3)*XPLUSD(I,2))*XPLUSD(I,2) - 410 CONTINUE - END IF - - IF (MOD(IDEVAL/100,10).NE.0) THEN - DO 420 I=1,N - FJACD(I,1,1) = BETA(1) - FJACD(I,2,1) = BETA(2)*EXP(BETA(3)*XPLUSD(I,2))*BETA(3) - 420 CONTINUE - END IF - - ELSE IF (SETNO.EQ.5) THEN - -C SETNO. 5: DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522 - - ISTOP = 0 - - IF (MOD(IDEVAL,10).NE.0) THEN - DO 500 I=1,N - F(I,1) = EXP(-BETA(1)*XPLUSD(I,1)* - + EXP(-BETA(2)*(ONE/XPLUSD(I,2) - ONE/620.0D0))) - 500 CONTINUE - END IF - - IF (MOD(IDEVAL/10,10).NE.0) THEN - DO 510 I=1,N - FAC1 = ONE/XPLUSD(I,2) - ONE/620.0D0 - FAC2 = EXP(-BETA(2)*FAC1) - FAC3 = BETA(1)*XPLUSD(I,1) - FAC4 = EXP(-FAC3*FAC2) - - FJACB(I,1,1) = -FAC4*XPLUSD(I,1)*FAC2 - FJACB(I,2,1) = FAC4*FAC3*FAC2*FAC1 - - IF (MOD(IDEVAL/100,10).NE.0) THEN - FJACD(I,1,1) = -FAC4*BETA(1)*FAC2 - FJACD(I,2,1) = -FAC4*FAC3*FAC2* - + BETA(2)/XPLUSD(I,2)**2 - END IF - 510 CONTINUE - END IF - - ELSE IF (SETNO.EQ.6) THEN - -C SETNO. 6: POWELL AND MACDONALD, 1972, TABLES 7 AND 8, PAGE 153-154 -C N.B. THIS DERIVATIVE IS INTENTIONALLY CODED INCORRECTLY - - ISTOP = 0 - - IF (MOD(IDEVAL,10).NE.0) THEN - DO 600 I=1,N - F(I,1) = BETA(1)* - + (ONE+BETA(3)*XPLUSD(I,1)/BETA(2))**(-ONE/BETA(3)) - 600 CONTINUE - END IF - - IF (MOD(IDEVAL/10,10).NE.0) THEN - DO 610 I=1,N - FJACB(I,1,1) = ZERO - FJACB(I,2,1) = ZERO - FJACB(I,3,1) = ZERO - - IF (MOD(IDEVAL/100,10).NE.0) THEN - FJACD(I,1,1) = XPLUSD(I,1) - END IF - 610 CONTINUE - END IF - - ELSE IF (SETNO.EQ.7) THEN - -C SETNO. 7: FULLER, 1987, TABLE 3.2.10, PAGES 244-245 -C N.B. THIS DERIVATIVE IS INTENTIONALLY CODED INCORRECTLY - - ISTOP = 0 - - IF (MOD(IDEVAL,10).NE.0) THEN - DO 700 I=1,N - F(I,1) = BETA(3)*(XPLUSD(I,1)-BETA(1))**2 + - + 2*BETA(4)*(XPLUSD(I,1)-BETA(1))* - + (XPLUSD(I,2)-BETA(2)) + - + BETA(5)*(XPLUSD(I,2)-BETA(2))**2 - 1.0D0 - 700 CONTINUE - END IF - - IF (MOD(IDEVAL/10,10).NE.0) THEN - DO 710 I=1,N - FJACB(I,1,1) = ZERO - FJACB(I,2,1) = ZERO - FJACB(I,3,1) = ZERO - FJACB(I,4,1) = ZERO - FJACB(I,5,1) = ZERO - - IF (MOD(IDEVAL/100,10).NE.0) THEN - FJACD(I,1,1) = ZERO - FJACD(I,2,1) = ZERO - END IF - 710 CONTINUE - END IF - - ELSE IF (SETNO.EQ.8) THEN - -C SETNO. 8: BATES AND WATTS, 1988, TABLE A1.13, PAGES 280-281 -C N.B. THIS DERIVATIVE IS INTENTIONALLY CODED INCORRECTLY - - DO 800 I=1,N - IF (XPLUSD(I,1).LT.0.0D0) THEN - ISTOP = 1 - RETURN - END IF - 800 CONTINUE - ISTOP = 0 - - IF (MOD(IDEVAL,10).NE.0) THEN - PI = 3.141592653589793238462643383279D0 - THETA = PI*BETA(4)*0.5D0 - CTHETA = COS(THETA) - STHETA = SIN(THETA) - DO 810 I=1,N - FREQ = XPLUSD(I,1) - OMEGA = (2.0D0*PI*FREQ*EXP(-BETA(3)))**BETA(4) - PHI = ATAN2((OMEGA*STHETA),(1+OMEGA*CTHETA)) - R = (BETA(1)-BETA(2)) * - + SQRT((1+OMEGA*CTHETA)**2+(OMEGA*STHETA)**2)** - + (-BETA(5)) - F(I,1) = BETA(2) + R*COS(BETA(5)*PHI) - F(I,2) = R*SIN(BETA(5)*PHI) - 810 CONTINUE - END IF - - IF (MOD(IDEVAL/10,10).NE.0) THEN - DO 820 I=1,N - FJACB(I,1,1) = ZERO - FJACB(I,2,1) = ZERO - FJACB(I,3,1) = ZERO - FJACB(I,4,1) = ZERO - FJACB(I,5,1) = ZERO - - FJACB(I,1,2) = ZERO - FJACB(I,2,2) = ZERO - FJACB(I,3,2) = ZERO - FJACB(I,4,2) = ZERO - FJACB(I,5,2) = ZERO - - IF (MOD(IDEVAL/100,10).NE.0) THEN - FJACD(I,1,1) = ZERO - FJACD(I,1,2) = ZERO - END IF - 820 CONTINUE - END IF - END IF - - RETURN - - END -*DODRXW - SUBROUTINE DODRXW - + (MAXN,MAXM,MAXNP,MAXNQ,LDWE,LD2WE,ISODR,LIWMIN,LWMIN) -C***BEGIN PROLOGUE DODRXW -C***REFER TO DODR,DODRC -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 890205 (YYMMDD) -C***REVISION DATE 920619 (YYMMDD) -C***PURPOSE COMPUTE MINIMUM LENGTHS FOR WORK VECTORS -C***ROUTINES CALLED NONE -C***END PROLOGUE DODRXW - -C...SCALAR ARGUMENTS - INTEGER - + LDWE,LD2WE,LIWMIN,LWMIN,MAXN,MAXM,MAXNP,MAXNQ - LOGICAL - + ISODR - -C...VARIABLE DEFINITIONS (ALPHABETICALLY) -C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR -C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). -C LDWE: THE LEADING DIMENSION OF ARRAY WE. -C LD2WE: THE SECOND DIMENSION OF ARRAY WE. -C LIWMIN: THE MINIMUM LENGTH OF VECTOR IWORK FOR A GIVEN PROBLEM. -C LWMIN: THE MINIMUM LENGTH OF VECTOR WORK FOR A GIVEN PROBLEM. -C MAXM: THE NUMBER OF COLUMNS IN THE EXPLANATORY VARIABLE. -C MAXN: THE NUMBER OF OBSERVATIONS. -C MAXNP: THE NUMBER OF FUNCTION PARAMETERS. -C MAXNQ: THE NUMBER OF RESPONSES PER OBSERVATION. - - -C***FIRST EXECUTABLE STATEMENT DODRXW - - - LIWMIN = 20+MAXNP+MAXNQ*(MAXNP+MAXM) - IF (ISODR) THEN - LWMIN = 18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + - + 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + - + 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + - + 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ - ELSE - LWMIN = 18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + - + 4*MAXN*MAXNQ + 2*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + - + 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ - END IF - - RETURN - END diff --git a/scipy/odr/odrpack/dlunoc.f b/scipy/odr/odrpack/dlunoc.f deleted file mode 100644 index 934ac343ad7d..000000000000 --- a/scipy/odr/odrpack/dlunoc.f +++ /dev/null @@ -1,22 +0,0 @@ - subroutine dluno - + (lun, fn) - - integer lun - character*(*) fn - - open(unit=lun, file=fn, status='new') - - return - - end - - subroutine dlunc - + (lun) - - integer lun - - close(unit=lun) - - return - - end diff --git a/scipy/odr/tests/__init__.py b/scipy/odr/tests/__init__.py deleted file mode 100644 index e69de29bb2d1..000000000000 diff --git a/scipy/odr/tests/meson.build b/scipy/odr/tests/meson.build deleted file mode 100644 index 5ba9df7bd4f6..000000000000 --- a/scipy/odr/tests/meson.build +++ /dev/null @@ -1,10 +0,0 @@ -python_sources = [ - '__init__.py', - 'test_odr.py' -] - -py3.install_sources( - python_sources, - subdir: 'scipy/odr/tests', - install_tag: 'tests' -) diff --git a/scipy/odr/tests/test_odr.py b/scipy/odr/tests/test_odr.py deleted file mode 100644 index 5d0545b01809..000000000000 --- a/scipy/odr/tests/test_odr.py +++ /dev/null @@ -1,621 +0,0 @@ -import pickle -import tempfile -import shutil -import os - -import numpy as np -from numpy import pi -from numpy.testing import (assert_array_almost_equal, - assert_equal, - assert_allclose) -import pytest -from pytest import raises as assert_raises - -from scipy.odr import (Data, Model, ODR, RealData, OdrStop, OdrWarning, - OdrError, multilinear, exponential, unilinear, - quadratic, polynomial) - - -class TestODR: - - # Bad Data for 'x' - - def test_bad_data(self): - assert_raises(ValueError, Data, 2, 1) - assert_raises(ValueError, RealData, 2, 1) - - # Empty Data for 'x' - def empty_data_func(self, B, x): - return B[0]*x + B[1] - - def test_empty_data(self): - beta0 = [0.02, 0.0] - linear = Model(self.empty_data_func) - - empty_dat = Data([], []) - with pytest.warns(OdrWarning): - ODR(empty_dat, linear, beta0=beta0) - - empty_dat = RealData([], []) - with pytest.warns(OdrWarning): - ODR(empty_dat, linear, beta0=beta0) - - # Explicit Example - - def explicit_fcn(self, B, x): - ret = B[0] + B[1] * np.power(np.exp(B[2]*x) - 1.0, 2) - return ret - - def explicit_fjd(self, B, x): - eBx = np.exp(B[2]*x) - ret = B[1] * 2.0 * (eBx-1.0) * B[2] * eBx - return ret - - def explicit_fjb(self, B, x): - eBx = np.exp(B[2]*x) - res = np.vstack([np.ones(x.shape[-1]), - np.power(eBx-1.0, 2), - B[1]*2.0*(eBx-1.0)*eBx*x]) - return res - - def test_explicit(self): - explicit_mod = Model( - self.explicit_fcn, - fjacb=self.explicit_fjb, - fjacd=self.explicit_fjd, - meta=dict(name='Sample Explicit Model', - ref='ODRPACK UG, pg. 39'), - ) - explicit_dat = Data([0.,0.,5.,7.,7.5,10.,16.,26.,30.,34.,34.5,100.], - [1265.,1263.6,1258.,1254.,1253.,1249.8,1237.,1218.,1220.6, - 1213.8,1215.5,1212.]) - explicit_odr = ODR(explicit_dat, explicit_mod, beta0=[1500.0, -50.0, -0.1], - ifixx=[0,0,1,1,1,1,1,1,1,1,1,0]) - explicit_odr.set_job(deriv=2) - explicit_odr.set_iprint(init=0, iter=0, final=0) - - out = explicit_odr.run() - assert_array_almost_equal( - out.beta, - np.array([1.2646548050648876e+03, -5.4018409956678255e+01, - -8.7849712165253724e-02]), - ) - assert_array_almost_equal( - out.sd_beta, - np.array([1.0349270280543437, 1.583997785262061, 0.0063321988657267]), - ) - assert_array_almost_equal( - out.cov_beta, - np.array([[4.4949592379003039e-01, -3.7421976890364739e-01, - -8.0978217468468912e-04], - [-3.7421976890364739e-01, 1.0529686462751804e+00, - -1.9453521827942002e-03], - [-8.0978217468468912e-04, -1.9453521827942002e-03, - 1.6827336938454476e-05]]), - ) - - # Implicit Example - - def implicit_fcn(self, B, x): - return (B[2]*np.power(x[0]-B[0], 2) + - 2.0*B[3]*(x[0]-B[0])*(x[1]-B[1]) + - B[4]*np.power(x[1]-B[1], 2) - 1.0) - - def test_implicit(self): - implicit_mod = Model( - self.implicit_fcn, - implicit=1, - meta=dict(name='Sample Implicit Model', - ref='ODRPACK UG, pg. 49'), - ) - implicit_dat = Data([ - [0.5,1.2,1.6,1.86,2.12,2.36,2.44,2.36,2.06,1.74,1.34,0.9,-0.28, - -0.78,-1.36,-1.9,-2.5,-2.88,-3.18,-3.44], - [-0.12,-0.6,-1.,-1.4,-2.54,-3.36,-4.,-4.75,-5.25,-5.64,-5.97,-6.32, - -6.44,-6.44,-6.41,-6.25,-5.88,-5.5,-5.24,-4.86]], - 1, - ) - implicit_odr = ODR(implicit_dat, implicit_mod, - beta0=[-1.0, -3.0, 0.09, 0.02, 0.08]) - - out = implicit_odr.run() - assert_array_almost_equal( - out.beta, - np.array([-0.9993809167281279, -2.9310484652026476, 0.0875730502693354, - 0.0162299708984738, 0.0797537982976416]), - ) - assert_array_almost_equal( - out.sd_beta, - np.array([0.1113840353364371, 0.1097673310686467, 0.0041060738314314, - 0.0027500347539902, 0.0034962501532468]), - ) - assert_allclose( - out.cov_beta, - np.array([[2.1089274602333052e+00, -1.9437686411979040e+00, - 7.0263550868344446e-02, -4.7175267373474862e-02, - 5.2515575927380355e-02], - [-1.9437686411979040e+00, 2.0481509222414456e+00, - -6.1600515853057307e-02, 4.6268827806232933e-02, - -5.8822307501391467e-02], - [7.0263550868344446e-02, -6.1600515853057307e-02, - 2.8659542561579308e-03, -1.4628662260014491e-03, - 1.4528860663055824e-03], - [-4.7175267373474862e-02, 4.6268827806232933e-02, - -1.4628662260014491e-03, 1.2855592885514335e-03, - -1.2692942951415293e-03], - [5.2515575927380355e-02, -5.8822307501391467e-02, - 1.4528860663055824e-03, -1.2692942951415293e-03, - 2.0778813389755596e-03]]), - rtol=1e-6, atol=2e-6, - ) - - # Multi-variable Example - - def multi_fcn(self, B, x): - if (x < 0.0).any(): - raise OdrStop - theta = pi*B[3]/2. - ctheta = np.cos(theta) - stheta = np.sin(theta) - omega = np.power(2.*pi*x*np.exp(-B[2]), B[3]) - phi = np.arctan2((omega*stheta), (1.0 + omega*ctheta)) - r = (B[0] - B[1]) * np.power(np.sqrt(np.power(1.0 + omega*ctheta, 2) + - np.power(omega*stheta, 2)), -B[4]) - ret = np.vstack([B[1] + r*np.cos(B[4]*phi), - r*np.sin(B[4]*phi)]) - return ret - - def test_multi(self): - multi_mod = Model( - self.multi_fcn, - meta=dict(name='Sample Multi-Response Model', - ref='ODRPACK UG, pg. 56'), - ) - - multi_x = np.array([30.0, 50.0, 70.0, 100.0, 150.0, 200.0, 300.0, 500.0, - 700.0, 1000.0, 1500.0, 2000.0, 3000.0, 5000.0, 7000.0, 10000.0, - 15000.0, 20000.0, 30000.0, 50000.0, 70000.0, 100000.0, 150000.0]) - multi_y = np.array([ - [4.22, 4.167, 4.132, 4.038, 4.019, 3.956, 3.884, 3.784, 3.713, - 3.633, 3.54, 3.433, 3.358, 3.258, 3.193, 3.128, 3.059, 2.984, - 2.934, 2.876, 2.838, 2.798, 2.759], - [0.136, 0.167, 0.188, 0.212, 0.236, 0.257, 0.276, 0.297, 0.309, - 0.311, 0.314, 0.311, 0.305, 0.289, 0.277, 0.255, 0.24, 0.218, - 0.202, 0.182, 0.168, 0.153, 0.139], - ]) - n = len(multi_x) - multi_we = np.zeros((2, 2, n), dtype=float) - multi_ifixx = np.ones(n, dtype=int) - multi_delta = np.zeros(n, dtype=float) - - multi_we[0,0,:] = 559.6 - multi_we[1,0,:] = multi_we[0,1,:] = -1634.0 - multi_we[1,1,:] = 8397.0 - - for i in range(n): - if multi_x[i] < 100.0: - multi_ifixx[i] = 0 - elif multi_x[i] <= 150.0: - pass # defaults are fine - elif multi_x[i] <= 1000.0: - multi_delta[i] = 25.0 - elif multi_x[i] <= 10000.0: - multi_delta[i] = 560.0 - elif multi_x[i] <= 100000.0: - multi_delta[i] = 9500.0 - else: - multi_delta[i] = 144000.0 - if multi_x[i] == 100.0 or multi_x[i] == 150.0: - multi_we[:,:,i] = 0.0 - - multi_dat = Data(multi_x, multi_y, wd=1e-4/np.power(multi_x, 2), - we=multi_we) - multi_odr = ODR(multi_dat, multi_mod, beta0=[4.,2.,7.,.4,.5], - delta0=multi_delta, ifixx=multi_ifixx) - multi_odr.set_job(deriv=1, del_init=1) - - out = multi_odr.run() - assert_array_almost_equal( - out.beta, - np.array([4.3799880305938963, 2.4333057577497703, 8.0028845899503978, - 0.5101147161764654, 0.5173902330489161]), - ) - assert_array_almost_equal( - out.sd_beta, - np.array([0.0130625231081944, 0.0130499785273277, 0.1167085962217757, - 0.0132642749596149, 0.0288529201353984]), - ) - assert_array_almost_equal( - out.cov_beta, - np.array([[0.0064918418231375, 0.0036159705923791, 0.0438637051470406, - -0.0058700836512467, 0.011281212888768], - [0.0036159705923791, 0.0064793789429006, 0.0517610978353126, - -0.0051181304940204, 0.0130726943624117], - [0.0438637051470406, 0.0517610978353126, 0.5182263323095322, - -0.0563083340093696, 0.1269490939468611], - [-0.0058700836512467, -0.0051181304940204, -0.0563083340093696, - 0.0066939246261263, -0.0140184391377962], - [0.011281212888768, 0.0130726943624117, 0.1269490939468611, - -0.0140184391377962, 0.0316733013820852]]), - ) - - # Pearson's Data - # K. Pearson, Philosophical Magazine, 2, 559 (1901) - - def pearson_fcn(self, B, x): - return B[0] + B[1]*x - - def test_pearson(self): - p_x = np.array([0.,.9,1.8,2.6,3.3,4.4,5.2,6.1,6.5,7.4]) - p_y = np.array([5.9,5.4,4.4,4.6,3.5,3.7,2.8,2.8,2.4,1.5]) - p_sx = np.array([.03,.03,.04,.035,.07,.11,.13,.22,.74,1.]) - p_sy = np.array([1.,.74,.5,.35,.22,.22,.12,.12,.1,.04]) - - p_dat = RealData(p_x, p_y, sx=p_sx, sy=p_sy) - - # Reverse the data to test invariance of results - pr_dat = RealData(p_y, p_x, sx=p_sy, sy=p_sx) - - p_mod = Model(self.pearson_fcn, meta=dict(name='Uni-linear Fit')) - - p_odr = ODR(p_dat, p_mod, beta0=[1.,1.]) - pr_odr = ODR(pr_dat, p_mod, beta0=[1.,1.]) - - out = p_odr.run() - assert_array_almost_equal( - out.beta, - np.array([5.4767400299231674, -0.4796082367610305]), - ) - assert_array_almost_equal( - out.sd_beta, - np.array([0.3590121690702467, 0.0706291186037444]), - ) - assert_array_almost_equal( - out.cov_beta, - np.array([[0.0854275622946333, -0.0161807025443155], - [-0.0161807025443155, 0.003306337993922]]), - ) - - rout = pr_odr.run() - assert_array_almost_equal( - rout.beta, - np.array([11.4192022410781231, -2.0850374506165474]), - ) - assert_array_almost_equal( - rout.sd_beta, - np.array([0.9820231665657161, 0.3070515616198911]), - ) - assert_array_almost_equal( - rout.cov_beta, - np.array([[0.6391799462548782, -0.1955657291119177], - [-0.1955657291119177, 0.0624888159223392]]), - ) - - # Lorentz Peak - # The data is taken from one of the undergraduate physics labs I performed. - - def lorentz(self, beta, x): - return (beta[0]*beta[1]*beta[2] / np.sqrt(np.power(x*x - - beta[2]*beta[2], 2.0) + np.power(beta[1]*x, 2.0))) - - def test_lorentz(self): - l_sy = np.array([.29]*18) - l_sx = np.array([.000972971,.000948268,.000707632,.000706679, - .000706074, .000703918,.000698955,.000456856, - .000455207,.000662717,.000654619,.000652694, - .000000859202,.00106589,.00106378,.00125483, .00140818,.00241839]) - - l_dat = RealData( - [3.9094, 3.85945, 3.84976, 3.84716, 3.84551, 3.83964, 3.82608, - 3.78847, 3.78163, 3.72558, 3.70274, 3.6973, 3.67373, 3.65982, - 3.6562, 3.62498, 3.55525, 3.41886], - [652, 910.5, 984, 1000, 1007.5, 1053, 1160.5, 1409.5, 1430, 1122, - 957.5, 920, 777.5, 709.5, 698, 578.5, 418.5, 275.5], - sx=l_sx, - sy=l_sy, - ) - l_mod = Model(self.lorentz, meta=dict(name='Lorentz Peak')) - l_odr = ODR(l_dat, l_mod, beta0=(1000., .1, 3.8)) - - out = l_odr.run() - assert_array_almost_equal( - out.beta, - np.array([1.4306780846149925e+03, 1.3390509034538309e-01, - 3.7798193600109009e+00]), - ) - assert_array_almost_equal( - out.sd_beta, - np.array([7.3621186811330963e-01, 3.5068899941471650e-04, - 2.4451209281408992e-04]), - ) - assert_array_almost_equal( - out.cov_beta, - np.array([[2.4714409064597873e-01, -6.9067261911110836e-05, - -3.1236953270424990e-05], - [-6.9067261911110836e-05, 5.6077531517333009e-08, - 3.6133261832722601e-08], - [-3.1236953270424990e-05, 3.6133261832722601e-08, - 2.7261220025171730e-08]]), - ) - - def test_ticket_1253(self): - def linear(c, x): - return c[0]*x+c[1] - - c = [2.0, 3.0] - x = np.linspace(0, 10) - y = linear(c, x) - - model = Model(linear) - data = Data(x, y, wd=1.0, we=1.0) - job = ODR(data, model, beta0=[1.0, 1.0]) - result = job.run() - assert_equal(result.info, 2) - - # Verify fix for gh-9140 - - def test_ifixx(self): - x1 = [-2.01, -0.99, -0.001, 1.02, 1.98] - x2 = [3.98, 1.01, 0.001, 0.998, 4.01] - fix = np.vstack((np.zeros_like(x1, dtype=int), np.ones_like(x2, dtype=int))) - data = Data(np.vstack((x1, x2)), y=1, fix=fix) - model = Model(lambda beta, x: x[1, :] - beta[0] * x[0, :]**2., implicit=True) - - odr1 = ODR(data, model, beta0=np.array([1.])) - sol1 = odr1.run() - odr2 = ODR(data, model, beta0=np.array([1.]), ifixx=fix) - sol2 = odr2.run() - assert_equal(sol1.beta, sol2.beta) - - # verify bugfix for #11800 in #11802 - def test_ticket_11800(self): - # parameters - beta_true = np.array([1.0, 2.3, 1.1, -1.0, 1.3, 0.5]) - nr_measurements = 10 - - std_dev_x = 0.01 - x_error = np.array([[0.00063445, 0.00515731, 0.00162719, 0.01022866, - -0.01624845, 0.00482652, 0.00275988, -0.00714734, -0.00929201, -0.00687301], - [-0.00831623, -0.00821211, -0.00203459, 0.00938266, -0.00701829, - 0.0032169, 0.00259194, -0.00581017, -0.0030283, 0.01014164]]) - - std_dev_y = 0.05 - y_error = np.array([[0.05275304, 0.04519563, -0.07524086, 0.03575642, - 0.04745194, 0.03806645, 0.07061601, -0.00753604, -0.02592543, -0.02394929], - [0.03632366, 0.06642266, 0.08373122, 0.03988822, -0.0092536, - -0.03750469, -0.03198903, 0.01642066, 0.01293648, -0.05627085]]) - - beta_solution = np.array([ - 2.62920235756665876536e+00, -1.26608484996299608838e+02, - 1.29703572775403074502e+02, -1.88560985401185465804e+00, - 7.83834160771274923718e+01, -7.64124076838087091801e+01]) - - # model's function and Jacobians - def func(beta, x): - y0 = beta[0] + beta[1] * x[0, :] + beta[2] * x[1, :] - y1 = beta[3] + beta[4] * x[0, :] + beta[5] * x[1, :] - - return np.vstack((y0, y1)) - - def df_dbeta_odr(beta, x): - nr_meas = np.shape(x)[1] - zeros = np.zeros(nr_meas) - ones = np.ones(nr_meas) - - dy0 = np.array([ones, x[0, :], x[1, :], zeros, zeros, zeros]) - dy1 = np.array([zeros, zeros, zeros, ones, x[0, :], x[1, :]]) - - return np.stack((dy0, dy1)) - - def df_dx_odr(beta, x): - nr_meas = np.shape(x)[1] - ones = np.ones(nr_meas) - - dy0 = np.array([beta[1] * ones, beta[2] * ones]) - dy1 = np.array([beta[4] * ones, beta[5] * ones]) - return np.stack((dy0, dy1)) - - # do measurements with errors in independent and dependent variables - x0_true = np.linspace(1, 10, nr_measurements) - x1_true = np.linspace(1, 10, nr_measurements) - x_true = np.array([x0_true, x1_true]) - - y_true = func(beta_true, x_true) - - x_meas = x_true + x_error - y_meas = y_true + y_error - - # estimate model's parameters - model_f = Model(func, fjacb=df_dbeta_odr, fjacd=df_dx_odr) - - data = RealData(x_meas, y_meas, sx=std_dev_x, sy=std_dev_y) - - odr_obj = ODR(data, model_f, beta0=0.9 * beta_true, maxit=100) - #odr_obj.set_iprint(init=2, iter=0, iter_step=1, final=1) - odr_obj.set_job(deriv=3) - - odr_out = odr_obj.run() - - # check results - assert_equal(odr_out.info, 1) - assert_array_almost_equal(odr_out.beta, beta_solution) - - def test_multilinear_model(self): - x = np.linspace(0.0, 5.0) - y = 10.0 + 5.0 * x - data = Data(x, y) - odr_obj = ODR(data, multilinear) - output = odr_obj.run() - assert_array_almost_equal(output.beta, [10.0, 5.0]) - - def test_exponential_model(self): - x = np.linspace(0.0, 5.0) - y = -10.0 + np.exp(0.5*x) - data = Data(x, y) - odr_obj = ODR(data, exponential) - output = odr_obj.run() - assert_array_almost_equal(output.beta, [-10.0, 0.5]) - - def test_polynomial_model(self): - x = np.linspace(0.0, 5.0) - y = 1.0 + 2.0 * x + 3.0 * x ** 2 + 4.0 * x ** 3 - poly_model = polynomial(3) - data = Data(x, y) - odr_obj = ODR(data, poly_model) - output = odr_obj.run() - assert_array_almost_equal(output.beta, [1.0, 2.0, 3.0, 4.0]) - - def test_unilinear_model(self): - x = np.linspace(0.0, 5.0) - y = 1.0 * x + 2.0 - data = Data(x, y) - odr_obj = ODR(data, unilinear) - output = odr_obj.run() - assert_array_almost_equal(output.beta, [1.0, 2.0]) - - def test_quadratic_model(self): - x = np.linspace(0.0, 5.0) - y = 1.0 * x ** 2 + 2.0 * x + 3.0 - data = Data(x, y) - odr_obj = ODR(data, quadratic) - output = odr_obj.run() - assert_array_almost_equal(output.beta, [1.0, 2.0, 3.0]) - - def test_work_ind(self): - - def func(par, x): - b0, b1 = par - return b0 + b1 * x - - # generate some data - n_data = 4 - x = np.arange(n_data) - y = np.where(x % 2, x + 0.1, x - 0.1) - x_err = np.full(n_data, 0.1) - y_err = np.full(n_data, 0.1) - - # do the fitting - linear_model = Model(func) - real_data = RealData(x, y, sx=x_err, sy=y_err) - odr_obj = ODR(real_data, linear_model, beta0=[0.4, 0.4]) - odr_obj.set_job(fit_type=0) - out = odr_obj.run() - - sd_ind = out.work_ind['sd'] - assert_array_almost_equal(out.sd_beta, - out.work[sd_ind:sd_ind + len(out.sd_beta)]) - - @pytest.mark.skipif(True, reason="Fortran I/O prone to crashing so better " - "not to run this test, see gh-13127") - def test_output_file_overwrite(self): - """ - Verify fix for gh-1892 - """ - def func(b, x): - return b[0] + b[1] * x - - p = Model(func) - data = Data(np.arange(10), 12 * np.arange(10)) - tmp_dir = tempfile.mkdtemp() - error_file_path = os.path.join(tmp_dir, "error.dat") - report_file_path = os.path.join(tmp_dir, "report.dat") - try: - ODR(data, p, beta0=[0.1, 13], errfile=error_file_path, - rptfile=report_file_path).run() - ODR(data, p, beta0=[0.1, 13], errfile=error_file_path, - rptfile=report_file_path, overwrite=True).run() - finally: - # remove output files for clean up - shutil.rmtree(tmp_dir) - - def test_odr_model_default_meta(self): - def func(b, x): - return b[0] + b[1] * x - - p = Model(func) - p.set_meta(name='Sample Model Meta', ref='ODRPACK') - assert_equal(p.meta, {'name': 'Sample Model Meta', 'ref': 'ODRPACK'}) - - def test_work_array_del_init(self): - """ - Verify fix for gh-18739 where del_init=1 fails. - """ - def func(b, x): - return b[0] + b[1] * x - - # generate some data - n_data = 4 - x = np.arange(n_data) - y = np.where(x % 2, x + 0.1, x - 0.1) - x_err = np.full(n_data, 0.1) - y_err = np.full(n_data, 0.1) - - linear_model = Model(func) - # Try various shapes of the `we` array from various `sy` and `covy` - rd0 = RealData(x, y, sx=x_err, sy=y_err) - rd1 = RealData(x, y, sx=x_err, sy=0.1) - rd2 = RealData(x, y, sx=x_err, sy=[0.1]) - rd3 = RealData(x, y, sx=x_err, sy=np.full((1, n_data), 0.1)) - rd4 = RealData(x, y, sx=x_err, covy=[[0.01]]) - rd5 = RealData(x, y, sx=x_err, covy=np.full((1, 1, n_data), 0.01)) - for rd in [rd0, rd1, rd2, rd3, rd4, rd5]: - odr_obj = ODR(rd, linear_model, beta0=[0.4, 0.4], - delta0=np.full(n_data, -0.1)) - odr_obj.set_job(fit_type=0, del_init=1) - # Just make sure that it runs without raising an exception. - odr_obj.run() - - def test_pickling_data(self): - x = np.linspace(0.0, 5.0) - y = 1.0 * x + 2.0 - data = Data(x, y) - - obj_pickle = pickle.dumps(data) - del data - pickle.loads(obj_pickle) - - def test_pickling_real_data(self): - x = np.linspace(0.0, 5.0) - y = 1.0 * x + 2.0 - data = RealData(x, y) - - obj_pickle = pickle.dumps(data) - del data - pickle.loads(obj_pickle) - - def test_pickling_model(self): - obj_pickle = pickle.dumps(unilinear) - pickle.loads(obj_pickle) - - def test_pickling_odr(self): - x = np.linspace(0.0, 5.0) - y = 1.0 * x + 2.0 - odr_obj = ODR(Data(x, y), unilinear) - - obj_pickle = pickle.dumps(odr_obj) - del odr_obj - pickle.loads(obj_pickle) - - def test_pickling_output(self): - x = np.linspace(0.0, 5.0) - y = 1.0 * x + 2.0 - output = ODR(Data(x, y), unilinear).run - - obj_pickle = pickle.dumps(output) - del output - pickle.loads(obj_pickle) - - def test_explicit_model_with_implicit_job(self): - """ - Verify fix for gh-23763 that ODR doesn't segfault - """ - x = np.linspace(0, 10, 10) - y = 2.0 + 3.0 * x - - data = Data(x, y) - model = unilinear # this is an explicit model - - # job=1 is implicit, should raise on explicit model - with assert_raises(OdrError): - odr = ODR(data, model, job=1) - odr.run() diff --git a/scipy/optimize/tests/test_optimize.py b/scipy/optimize/tests/test_optimize.py index 80e0198068d1..c23e3646867d 100644 --- a/scipy/optimize/tests/test_optimize.py +++ b/scipy/optimize/tests/test_optimize.py @@ -3000,9 +3000,6 @@ def jacobian2(x): # This test is about handling fixed variables, not the accuracy of the solvers @pytest.mark.xfail_on_32bit("Failures due to floating point issues, not logic") -@pytest.mark.xfail(scipy.show_config(mode='dicts')['Compilers']['fortran']['name'] == - "intel-llvm", - reason="Failures due to floating point issues, not logic") @pytest.mark.parametrize('method', eb_data["methods"]) @pytest.mark.parametrize('kwds', eb_data["kwds"]) @pytest.mark.parametrize('bound_type', eb_data["bound_types"]) diff --git a/scipy/optimize/tests/test_slsqp.py b/scipy/optimize/tests/test_slsqp.py index 43cb377dab41..59873e4f48c1 100644 --- a/scipy/optimize/tests/test_slsqp.py +++ b/scipy/optimize/tests/test_slsqp.py @@ -524,9 +524,6 @@ def f(x): assert_(sol.success) assert_allclose(sol.x, 0, atol=1e-10) - @pytest.mark.xfail(scipy.show_config(mode='dicts')['Compilers']['fortran']['name'] - == "intel-llvm", - reason="Runtime warning due to floating point issues, not logic") def test_inconsistent_inequalities(self): # gh-7618