diff --git a/.github/workflows/real-libraries-portability.yml b/.github/workflows/real-libraries-portability.yml index 2b72340f6..a18050ece 100644 --- a/.github/workflows/real-libraries-portability.yml +++ b/.github/workflows/real-libraries-portability.yml @@ -157,6 +157,10 @@ jobs: run: | source examples/fortran/bspline/build_all.sh python -m pytest -q examples/fortran/bspline/tests + - name: Run PRIMA example + run: | + source examples/fortran/prima/build_all.sh + python -m pytest -q examples/fortran/prima/tests - name: Run Pythonic BLAS API example run: | source examples/fortran/pythonic_blas/build.sh diff --git a/CHANGELOG.md b/CHANGELOG.md index 9ca6a42dd..fdd7f815e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,17 @@ release tags add a leading `v` to the package version. ## Unreleased +- `--export-symbols` and `build_fortran_extension(export_symbols=...)` accept + module-qualified Fortran procedure identities. Generated contracts and + source builds publish only that reviewed function surface while retaining + callback, type, and other declaration dependencies required by its + signatures. +- The PRIMA example links five derivative-free solvers against one statically + compiled `libprimaf` archive through a generated semantic contract and runs + in the real-library portability matrix. Its guide includes a reproducible + build, source-checked build and test examples, and an optional SciPy COBYLA + parity check. + - Forwardable Fortran optional arguments use a linear number of contained procedures and converge on one native call site instead of enumerating presence combinations. Descriptor categories that cannot be forwarded, diff --git a/README.md b/README.md index 919e39ce9..96eadc520 100644 --- a/README.md +++ b/README.md @@ -170,7 +170,7 @@ provides task-oriented recipes for reshaping the API. ## Proven on real libraries -PRIK builds and numerically tests seven maintained libraries, not just generated +PRIK builds and numerically tests eight maintained libraries, not just generated wrappers. | Project | Native language and PRIK input | Validated surface | @@ -180,10 +180,11 @@ wrappers. | [FFTPACK](https://pynumlab.github.io/prik/user/examples/fortran/fftpack-wrapper/) | Fortran source/interfaces | 31 Fourier, cosine, and sine transform procedures | | [MINPACK](https://pynumlab.github.io/prik/user/examples/fortran/minpack-wrapper/) | Fortran source/interfaces | 22 nonlinear and least-squares procedures, including callbacks | | [BSPLINE-FORTRAN](https://pynumlab.github.io/prik/user/examples/fortran/bspline-wrapper/) | Fortran source/interfaces | 15 interpolation routines and modern Fortran classes | +| [PRIMA](https://pynumlab.github.io/prik/user/examples/fortran/prima-wrapper/) | Fortran source and generated contract; link static archive | 5 derivative-free solvers with Python callbacks | | [libm](https://pynumlab.github.io/prik/user/examples/c/libm-wrapper/) | C declarations from ``; link compiled platform libm | 60 target-generated ISO C99 math functions | | [TA-Lib](https://pynumlab.github.io/prik/user/examples/c/ta-lib-wrapper/) | C declarations from `ta_libc.h`; link compiled `libta-lib` | All 322 double and float-input indicators over NumPy arrays, checked against TA-Lib's reference results | -The **Real Libraries Portability** workflow runs all seven on Linux x86-64, +The **Real Libraries Portability** workflow runs all eight on Linux x86-64, Linux ARM64, macOS Intel, and macOS ARM64 with Python 3.12. See the [Examples Gallery](https://pynumlab.github.io/prik/user/examples/#tested-platforms) for the compiler matrix; each project guide also records its own tested platforms. diff --git a/docs/developer/testing-strategy.md b/docs/developer/testing-strategy.md index a91e9197f..9ade4963b 100644 --- a/docs/developer/testing-strategy.md +++ b/docs/developer/testing-strategy.md @@ -94,8 +94,8 @@ reparse source — and say why in the test name or a comment beside it. A modified-contract test stays separate because it asserts a deliberately different public API. -The real-library suite covers five Fortran projects—BLAS, LAPACK, FFTPACK, -MINPACK, and BSPLINE-FORTRAN—plus the C libm and TA-Lib projects. +The real-library suite covers six Fortran projects—BLAS, LAPACK, FFTPACK, +MINPACK, BSPLINE-FORTRAN, and PRIMA—plus the C libm and TA-Lib projects. ## Test And Fixture Placement diff --git a/docs/developer/workflows/quality-assurance.md b/docs/developer/workflows/quality-assurance.md index e65b96741..1db5d3fed 100644 --- a/docs/developer/workflows/quality-assurance.md +++ b/docs/developer/workflows/quality-assurance.md @@ -95,8 +95,8 @@ Minimize an actionable fuzz failure and retain it as a focused regression. Native changes need focused codegen evidence and relevant end-to-end coverage. Ordinary local runs exclude `real_library`. Maintained coverage includes the -five Fortran examples—BLAS, LAPACK, FFTPACK, MINPACK, and BSPLINE-FORTRAN—and +six Fortran examples—BLAS, LAPACK, FFTPACK, MINPACK, BSPLINE-FORTRAN, and PRIMA—and the C libm and TA-Lib examples across the hosted portability matrix. Each has -its own example workflow; leave LAPACK wrapper tests to GitHub Actions -unless explicitly requested. See [Pull request checks](ci.md) for hosted +its own build and tests in that workflow; leave LAPACK wrapper tests to GitHub +Actions unless explicitly requested. See [Pull request checks](ci.md) for hosted coverage, compiler, real-library, benchmark, and documentation evidence. diff --git a/docs/index.md b/docs/index.md index 48f893c22..ee2929c21 100644 --- a/docs/index.md +++ b/docs/index.md @@ -294,12 +294,13 @@ its `.pyi` contract. It needs no installation. ## Proven on real libraries -The maintained example suite covers five Fortran libraries— +The maintained example suite covers six Fortran libraries— [BLAS](user/examples/fortran/blas-wrapper.md), [LAPACK](user/examples/fortran/lapack-wrapper.md), [FFTPACK](user/examples/fortran/fftpack-wrapper.md), -[MINPACK](user/examples/fortran/minpack-wrapper.md), and -[BSPLINE-FORTRAN](user/examples/fortran/bspline-wrapper.md)—and two C +[MINPACK](user/examples/fortran/minpack-wrapper.md), +[BSPLINE-FORTRAN](user/examples/fortran/bspline-wrapper.md), and +[PRIMA](user/examples/fortran/prima-wrapper.md)—and two C libraries: [libm](user/examples/c/libm-wrapper.md) and [TA-Lib](user/examples/c/ta-lib-wrapper.md). Each project has a complete build and numerical validation workflow, including its tested platforms and diff --git a/docs/user/examples/fortran/prima-wrapper.md b/docs/user/examples/fortran/prima-wrapper.md new file mode 100644 index 000000000..20fd4fe91 --- /dev/null +++ b/docs/user/examples/fortran/prima-wrapper.md @@ -0,0 +1,275 @@ +--- +title: Build and Validate PRIMA with PRIK +audience: users, advanced users +prerequisites: arrays, callbacks, packaging +related: ../../guide/callbacks.md, ../../reference/cli-commands.md +status: maintained +publication: reviewed +--- + +# Build and Validate PRIMA with PRIK + +This example builds the checked-in [libPRIMA](https://github.com/libprima/prima) +Fortran sources once and wraps five derivative-free solvers as one Python +extension. Its numerical tests exercise Python callbacks and check known +solutions. + +### What this example shows + +- Select five `module::procedure` entrypoints while retaining the callback + declarations their signatures need. +- Link a PRIK wrapper to a prebuilt static Fortran archive without compiling + the native sources twice. +- Call the solvers from Python, including optional callbacks and optional + arguments inside callback interfaces. + +You should already be comfortable with NumPy arrays, Python callables, and +building a local Fortran extension. + +--- + +## Versions used + +| Component | Version / source | +| --- | --- | +| PRIK | current repository checkout | +| PRIMA | [libprima/prima commit `1d76fb88`](https://github.com/libprima/prima/tree/1d76fb88aeffb427cd17ed1e9d0d3b34f414913f) | +| Python | 3.12 in the dedicated CI job | +| NumPy | 2.5.1 | +| SciPy (optional comparison) | 1.18.0 in CI | +| Native compilers | GNU Fortran 13 + GCC 13 in CI; compatible local compilers work | + +The source snapshot lives under `examples/fortran/prima/native/`; the build +does not download PRIMA. + +## Tested platforms + +The Real Libraries Portability workflow builds and runs the numerical suite +with Python 3.12 on: + +| Operating system | Architectures | Native toolchain | +| --- | --- | --- | +| Linux | x86-64, ARM64 | GNU Fortran 13 + GCC 13 | +| macOS | Intel, ARM64 | GNU Fortran 13 + GNU GCC 13 | + +--- + +## 1. Prepare the repository and toolchain + +Clone PRIK, create a virtual environment, and install the Python tools used by +the dedicated CI job: + +```bash +git clone https://github.com/PyNumLab/prik.git +cd prik +python3 -m venv .venv +. .venv/bin/activate +python3 -m pip install --upgrade pip +python3 -m pip install -e ".[qa]" "numpy==2.5.1" +``` + +Install CMake and GNU Fortran separately. On Ubuntu: + +```bash +sudo apt-get update +sudo apt-get install --yes cmake gcc gfortran +gfortran --version +``` + +All remaining commands run from the repository root in this shell with the +virtual environment active. The runnable project lives under +[`examples/fortran/prima/`](../../../../examples/fortran/prima/). + +--- + +## 2. Build the PRIK wrapper + +The build script compiles PRIMA into `libprimaf.a`, selects five public +procedures for the generated `.pyi` contract, and links the wrapper against +that archive: + + +```bash +export EXAMPLE_WORKSPACE="$PWD" +export PRIMA_BUILD_ROOT="$(mktemp -d)" + +mkdir -p "$PRIMA_BUILD_ROOT/prik/generated" + +cmake \ + -S "$EXAMPLE_WORKSPACE/examples/fortran/prima" \ + -B "$PRIMA_BUILD_ROOT/native" \ + -DCMAKE_BUILD_TYPE=Release \ + -DCMAKE_Fortran_COMPILER="$(command -v gfortran)" +cmake --build "$PRIMA_BUILD_ROOT/native" --target primaf --parallel 2 + +PRIMA_SOURCES=() +while IFS= read -r source; do + PRIMA_SOURCES+=("$EXAMPLE_WORKSPACE/examples/fortran/prima/native/$source") +done < "$EXAMPLE_WORKSPACE/examples/fortran/prima/sources.txt" + +python3 -m prik generate --pyi \ + "${PRIMA_SOURCES[@]}" \ + --export-symbols "$EXAMPLE_WORKSPACE/examples/fortran/prima/export_symbols.txt" \ + --out "$PRIMA_BUILD_ROOT/contract" \ + --compiler "$(command -v gfortran)" \ + -I "$EXAMPLE_WORKSPACE/examples/fortran/prima/native/common" \ + -D PRIMA_REAL_PRECISION=64 \ + -D PRIMA_INTEGER_KIND=0 + +cd "$PRIMA_BUILD_ROOT/prik" +python3 -m prik "$PRIMA_BUILD_ROOT/contract/__init__.pyi" \ + --out prik_prima \ + --out-dir "$PRIMA_BUILD_ROOT/prik/generated" \ + --compiler "$(command -v gfortran)" \ + --native-link-item "archive:$PRIMA_BUILD_ROOT/native/libprimaf.a" \ + --native-linker-language fortran \ + -I "$PRIMA_BUILD_ROOT/native/mod" \ + --jobs 2 +``` + +CMake compiles the 55 native sources once. PRIK analyzes those same sources +with matching real-precision and integer-kind settings, then links its +generated wrapper to the archive. + +For normal use, source the convenience entrypoint: + +```bash +source examples/fortran/prima/build_all.sh +``` + +It builds the extension, exports its directory on `PYTHONPATH`, and records +the temporary build directory in `PRIMA_BUILD_ROOT` for this shell. + +--- + +## 3. Use the generated Python API + +The public Python API has exactly these entries: + +| Module | Solver | +| --- | --- | +| `bobyqa_mod` | `bobyqa` | +| `cobyla_mod` | `cobyla` | +| `lincoa_mod` | `lincoa` | +| `newuoa_mod` | `newuoa` | +| `uobyqa_mod` | `uobyqa` | + +For example, UOBYQA minimizes a two-variable quadratic whose known minimum is +at `(1, -2)`. After building the extension, run this in Python: + +```python +import numpy as np +import prik_prima + +x = np.asfortranarray(np.array([3.0, 0.0], dtype=np.float64)) + +def objective(values, result): + result[...] = (values[0] - 1.0) ** 2 + (values[1] + 2.0) ** 2 + +prik_prima.uobyqa_mod.uobyqa(objective, x, maxfun=np.int32(100)) +np.testing.assert_allclose(x, [1.0, -2.0], atol=2e-3, rtol=0) +print(x) +``` + +The callback writes the objective value into `result`; the solver updates `x` +in place. The assertion checks the result against the known minimum. + +--- + +## 4. Run the complete test suite + +After the build finishes, run: + +```bash +python3 -m pytest -q examples/fortran/prima/tests +``` + +The suite checks a numerical result for each of the five exposed solvers, +exact API selection, and callback behavior when optional arguments are +present or omitted. It is not an exhaustive solver-option or constraint +suite. + +--- + +## 5. See how results are validated + +For the quadratic in section 3, the known minimizer `(1, -2)` is the primary +numerical check. The COBYLA test below also confirms that its optional +progress callback receives the expected argument shapes. The test file's +`_objective` helper evaluates `(x[0] - 1)^2 + (x[1] + 2)^2`: + + +```python +def test_cobyla_runs_with_every_optional_callback_dummy_present(prima): + x = np.asfortranarray(np.array([3.0, 0.0], dtype=np.float64)) + observed = [] + + def objective_and_constraints(values, f, constraints): + _objective(values, f) + + def progress(values, f, nf, tr, cstrv, nlconstr, terminate): + observed.append((f, nf, tr, cstrv, nlconstr.shape, terminate.shape)) + + prima.cobyla_mod.cobyla( + objective_and_constraints, + np.int32(0), + x, + maxfun=np.int32(100), + callback_fcn=progress, + ) + + np.testing.assert_allclose(x, np.array([1.0, -2.0]), atol=2.0e-3, rtol=0.0) + assert observed + assert observed[-1][4:] == ((0,), ()) +``` + +SciPy 1.18's +[COBYLA implementation](https://docs.scipy.org/doc/scipy/reference/optimize.minimize-cobyla.html) +also comes from PRIMA, so the optional SciPy test is a cross-interface parity +check rather than an independent algorithmic oracle. Both results are also +checked against the known minimizer `(1, -2)`. + +--- + +## 6. Run focused examples + +After building the extension, run one solver test or the optional SciPy +comparison: + +```bash +python3 -m pytest -q examples/fortran/prima/tests/test_solvers.py::test_lincoa_minimizes_a_quadratic +python3 -m pip install "scipy==1.18.0" +python3 -m pytest -q examples/fortran/prima/tests/test_solvers.py::test_cobyla_agrees_with_scipy_on_a_quadratic +``` + +The checked-in test file is a starting point for your own cases: add a +`test_*` function there, or a `test_*.py` file beside it. The shared `prima` +fixture imports the built extension. Change the objective, initial `x`, and +expected result, then run your new test with the same pytest command. + +- Solver and callback examples → + [`test_solvers.py`](../../../../examples/fortran/prima/tests/test_solvers.py) +- Reviewed API selection → + [`export_symbols.txt`](../../../../examples/fortran/prima/export_symbols.txt) +- Copyable build script → + [`build_prik.sh`](../../../../examples/fortran/prima/build_prik.sh) +- Project instructions → + [`examples/fortran/prima/README.md`](../../../../examples/fortran/prima/README.md) + +--- + +## Troubleshooting + +- Confirm that `cmake` and `gfortran` are available on `PATH`. +- Use `source examples/fortran/prima/build_all.sh`; executing it in a child + shell does not preserve the exported `PYTHONPATH`. +- SciPy is optional. The COBYLA comparison skips if it is not installed. +- Run one failing solver test with `-vv -s` to see its output. + +--- + +## Source provenance + +The files under [`examples/fortran/prima/native/`](../../../../examples/fortran/prima/native/) +match [libprima/prima commit `1d76fb88aeffb427cd17ed1e9d0d3b34f414913f`](https://github.com/libprima/prima/tree/1d76fb88aeffb427cd17ed1e9d0d3b34f414913f). +They retain the upstream [BSD 3-Clause license](../../../../examples/fortran/prima/LICENCE.txt). diff --git a/docs/user/examples/index.md b/docs/user/examples/index.md index 2b9701a39..1c4b69a99 100644 --- a/docs/user/examples/index.md +++ b/docs/user/examples/index.md @@ -9,15 +9,15 @@ publication: reviewed # Examples Gallery -This section includes seven complete real-library examples: BLAS, LAPACK, -FFTPACK, MINPACK, BSPLINE-FORTRAN, libm, and TA-Lib. Each one provides build +This section includes eight complete real-library examples: BLAS, LAPACK, +FFTPACK, MINPACK, BSPLINE-FORTRAN, PRIMA, libm, and TA-Lib. Each one provides build commands, Python usage, and numerical checks for its public routines. The native-language boundary is deliberately explicit: | Native language | Examples | What PRIK consumes | | --- | --- | --- | -| Fortran | BLAS, LAPACK, FFTPACK, MINPACK, BSPLINE-FORTRAN | Fortran source and interfaces, which the native build compiles and the wrapper exposes | +| Fortran | BLAS, LAPACK, FFTPACK, MINPACK, BSPLINE-FORTRAN, PRIMA | Fortran source and interfaces; builds compile the implementation or link a separately built library | | C | libm, TA-Lib | Public C header declarations plus an already compiled library to link; implementation `.c` files are not wrapper inputs | For libm, the declaration source is the platform's `` and the linked @@ -38,6 +38,7 @@ coverage differs by project: | FFTPACK | GNU Fortran 13 + GCC 13 | GNU Fortran 13 + GNU GCC 13 | x86-64 and ARM64 | | MINPACK | GNU Fortran 13 + GCC 13 | GNU Fortran 13 + GNU GCC 13 | x86-64 and ARM64 | | BSPLINE-FORTRAN | GNU Fortran 13 + GCC 13 | GNU Fortran 13 + GNU GCC 13 | x86-64 and ARM64 | +| PRIMA | GNU Fortran 13 + GCC 13 | GNU Fortran 13 + GNU GCC 13 | x86-64 and ARM64 | | libm | GCC 13 and Clang 18 | Apple Clang and GNU GCC 13 | x86-64/Intel and ARM64 | | TA-Lib | GCC 13 | Apple Clang | x86-64/Intel and ARM64 | @@ -61,6 +62,7 @@ their source-level declarations and interfaces. | Wrap and validate all 31 FFTPACK procedures with NumPy and SciPy | [FFTPACK wrapper](fortran/fftpack-wrapper.md) | | Wrap all 22 MINPACK procedures and use Python callbacks | [MINPACK wrapper](fortran/minpack-wrapper.md) | | Build and validate modern Fortran classes and 15 interpolation routines | [BSPLINE-FORTRAN wrapper](fortran/bspline-wrapper.md) | +| Build and validate five PRIMA optimization solvers with Python callbacks | [PRIMA wrapper](fortran/prima-wrapper.md) | ## C libraries diff --git a/docs/user/faq/index.md b/docs/user/faq/index.md index 80bd4ba8f..6a6ade42f 100644 --- a/docs/user/faq/index.md +++ b/docs/user/faq/index.md @@ -42,9 +42,10 @@ into the same extension. The [shared-library guide](../guide/building-shared-library.md) explains the build options, while the tested [BLAS](../examples/fortran/blas-wrapper.md), [LAPACK](../examples/fortran/lapack-wrapper.md), [FFTPACK](../examples/fortran/fftpack-wrapper.md), -[MINPACK](../examples/fortran/minpack-wrapper.md), and -[BSPLINE-FORTRAN](../examples/fortran/bspline-wrapper.md) examples show complete -libraries. The [example gallery](../examples/index.md) also includes the C +[MINPACK](../examples/fortran/minpack-wrapper.md), +[BSPLINE-FORTRAN](../examples/fortran/bspline-wrapper.md), and +[PRIMA](../examples/fortran/prima-wrapper.md) examples show real-library +builds. The [example gallery](../examples/index.md) also includes the C [libm](../examples/c/libm-wrapper.md) and [TA-Lib](../examples/c/ta-lib-wrapper.md). @@ -107,7 +108,7 @@ for the complete boundary.
-How do I wrap an existing C library or large header? +How do I wrap a reviewed surface from a large C or Fortran library? First create `symbols.txt` with one C function name per line: @@ -132,6 +133,18 @@ controls what the contract publishes and `--export-symbols` is no longer used. Adding a name to `__all__` publishes a declaration the contract already reaches; it cannot conjure one the C sources never declared. +For Fortran, list module-qualified procedures instead: + +```text +solver_mod::solve +optimizer_mod::minimize +``` + +Pass the library's source universe to `generate --pyi`. PRIK uses it to resolve +kind parameters, callback prototypes, derived types, and other declaration +dependencies, while the generated contract contains only the selected +procedure surface and the declarations its signatures require. + Pass the header's normal `-I`, `-D`, and `--std` options when it needs them. Review `vendor.pyi` before building. Primitive scalar signatures are ready to use; edit pointer parameters when they represent arrays, outputs, or strings. diff --git a/docs/user/index.md b/docs/user/index.md index d77137024..d2f304ca4 100644 --- a/docs/user/index.md +++ b/docs/user/index.md @@ -34,8 +34,8 @@ designed API. Performance presents the reproducible PRIK and f2py comparison. generated-wrapper surfaces. Start with [`.pyi` Format](reference/pyi-format.md) for the contract language and [Editing `.pyi` Contracts](reference/pyi-contracts/index.md) for supported recipes. -- [Examples](examples/index.md) — five complete Fortran projects (BLAS, LAPACK, - FFTPACK, MINPACK, and BSPLINE-FORTRAN) plus the C +- [Examples](examples/index.md) — six complete Fortran projects (BLAS, LAPACK, + FFTPACK, MINPACK, BSPLINE-FORTRAN, and PRIMA) plus the C [libm](examples/c/libm-wrapper.md) and [TA-Lib](examples/c/ta-lib-wrapper.md) projects. - [Troubleshooting](troubleshooting/compiler-issues.md) — compiler detection, diff --git a/docs/user/reference/cli-commands.md b/docs/user/reference/cli-commands.md index 942dc3ae8..ed27c4d10 100644 --- a/docs/user/reference/cli-commands.md +++ b/docs/user/reference/cli-commands.md @@ -378,6 +378,43 @@ locations come from the template's own output. `--compile-commands PATH` reads per-file C preprocessing commands from a `compile_commands.json` database. It is available only for C input. +## Source export selection + +`--export-symbols FILE` selects the exact function surface to convert from +native source. It is available for C and Fortran source commands, including +source builds, `semantics`, and `generate --pyi`. A generated contract records +the corresponding Python names in `__all__`; when building that contract, +edit `__all__` instead of passing `--export-symbols` again. + +The UTF-8 file contains one identity per line. Blank lines and text after `#` +are ignored. C functions use their native identifier: + +```text +vendor_open +vendor_close +``` + +Fortran module procedures use a case-insensitive, module-qualified identity: + +```text +bobyqa_mod::bobyqa +cobyla_mod::cobyla +``` + +Qualification keeps procedures with the same spelling in different modules +distinct. The module side must name a declared Fortran `module`, not a +file-level external-procedure group. Every listed identity must resolve to +exactly one reachable function. Empty files, invalid or repeated identities, +unknown declarations, and names that do not denote functions fail the command. + +Fortran extraction retains declarations needed to express the selected +signatures, such as callback prototypes and derived types, without publishing +them as additional callable functions. Unselected procedures and unrelated +modules are omitted from the generated contract. The positional inputs remain +the native source universe used to resolve those dependencies and, for a +source build, the implementation sources compiled unless +`--no-compile-input-sources` is selected. + ## C include exposure These C-only options decide which reachable project headers become public @@ -389,13 +426,11 @@ C contracts—not whether the native compiler can find an include file. | `--include-exposure {reachable-project,roots-only}` | Exposes reachable project headers by default, or only the root inputs. | | `--public-include PATH_OR_PATTERN` | Exposes declarations from matching included files. Repeat as needed. | | `--private-include PATH_OR_PATTERN` | Hides declarations from matching included files. Repeat as needed. | -| `--export-symbols FILE` | Selects the exact reachable C functions named by FILE as the source-side public surface, including declarations from otherwise-private system headers. `generate --pyi` records the corresponding Python public names in the contract's `__all__`. | +| `--export-symbols FILE` | Selects the exact reachable C functions named by FILE, including declarations from otherwise-private system headers. | -`--export-symbols` is a function-only allowlist for commands that read C -source: source builds, `semantics`, and `generate --pyi`. It defines the -source-side public function surface. When `generate --pyi` writes that surface -as an editable semantic contract, the corresponding Python public names are -written to the contract's `__all__`. +For C, the option remains an explicit exception to `roots-only`, system-header +privacy, and matching `--private-include` rules. It does not change native +linking or make an unsupported selected signature buildable. The two lists live in different naming domains: the file names native C identifiers, and `__all__` names what the contract publishes to Python. After @@ -403,15 +438,8 @@ generation the contract is authoritative — edit `__all__` to change what it publishes rather than passing `--export-symbols` again, which a contract build rejects. -The UTF-8 file contains one ASCII C identifier per line; blank lines and text -after `#` are ignored. -Every listed name must resolve to exactly one reachable function. Empty files, -invalid or repeated names, unknown names, names of non-function declarations, -and ambiguous declarations fail the command. All declarations not selected by -the file are removed from that semantic surface. This makes the allowlist the -explicit exception to `roots-only`, system-header privacy, and matching -`--private-include` rules; it does not change native linking or make an -unsupported selected signature buildable. +All C declarations not selected by the file are removed from that semantic +surface. ## Output and diagnostics diff --git a/docs/user/reference/python-api.md b/docs/user/reference/python-api.md index bb2c509e9..28c10ef03 100644 --- a/docs/user/reference/python-api.md +++ b/docs/user/reference/python-api.md @@ -99,6 +99,20 @@ Unknown names fail the build rather than silently producing a smaller module. Once you author or generate a semantic `.pyi` contract, that contract's own `__all__` states the public surface and `export_symbols` no longer applies. +`build_fortran_extension` accepts the same option with module-qualified native +procedure identities. PRIK retains signature dependencies while publishing +only the selected procedures: + +```python +from prik import build_fortran_extension + +build = build_fortran_extension( + fortran_sources, + output_dir="build", + export_symbols=["solver_mod::solve", "solver_mod::minimize"], +) +``` + For an authored C semantic contract, use `build_pyi_extension` with `native_language="c"` and `native_c_sources=[...]`. [C Pointers, Arrays, and Strings](../guide/c/pointers-arrays-and-strings.md#author-a-contract-for-pointers-and-arrays) diff --git a/examples/fortran/README.md b/examples/fortran/README.md index c24642600..66effbccc 100644 --- a/examples/fortran/README.md +++ b/examples/fortran/README.md @@ -10,6 +10,7 @@ bindings from their source declarations and interfaces. | [FFTPACK](fftpack/README.md) | 31 Fourier, cosine, and sine transform procedures | | [MINPACK](minpack/README.md) | 22 nonlinear and least-squares procedures | | [BSPLINE-FORTRAN](bspline/README.md) | 15 interpolation routines and modern Fortran classes | +| [PRIMA](prima/README.md) | 5 derivative-free optimization solvers with required and optional callbacks | Each project README gives its build command, supported surface, numerical checks, and portability boundary. Run commands from the repository root. diff --git a/examples/fortran/prima/CMakeLists.txt b/examples/fortran/prima/CMakeLists.txt new file mode 100644 index 000000000..712e82bac --- /dev/null +++ b/examples/fortran/prima/CMakeLists.txt @@ -0,0 +1,19 @@ +cmake_minimum_required(VERSION 3.18) +project(prik_prima_native LANGUAGES Fortran) + +file(STRINGS "${CMAKE_CURRENT_SOURCE_DIR}/sources.txt" PRIMA_SOURCE_NAMES) +set(PRIMA_SOURCES) +foreach(source IN LISTS PRIMA_SOURCE_NAMES) + list(APPEND PRIMA_SOURCES "${CMAKE_CURRENT_SOURCE_DIR}/native/${source}") +endforeach() + +add_library(primaf STATIC ${PRIMA_SOURCES}) +set_target_properties(primaf PROPERTIES + POSITION_INDEPENDENT_CODE ON + Fortran_MODULE_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/mod" +) +target_compile_definitions(primaf PUBLIC + PRIMA_REAL_PRECISION=64 + PRIMA_INTEGER_KIND=0 +) +target_include_directories(primaf PRIVATE "${CMAKE_CURRENT_SOURCE_DIR}/native/common") diff --git a/examples/fortran/prima/LICENCE.txt b/examples/fortran/prima/LICENCE.txt new file mode 100644 index 000000000..deb166c91 --- /dev/null +++ b/examples/fortran/prima/LICENCE.txt @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2020--2026, Zaikun ZHANG ( https://www.zhangzk.net ) + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/examples/fortran/prima/README.md b/examples/fortran/prima/README.md new file mode 100644 index 000000000..e22361daf --- /dev/null +++ b/examples/fortran/prima/README.md @@ -0,0 +1,52 @@ +# Wrap PRIMA with PRIK + +Build the bundled modern [libPRIMA](https://github.com/libprima/prima) +implementation as a static library, extract a reviewed five-solver contract, +and link one Python extension without compiling any PRIMA source twice. + +## Requirements + +Install CMake and GNU Fortran. On Ubuntu: + +```console +sudo apt-get update +sudo apt-get install --yes cmake gfortran +``` + +Run the remaining commands from the PRIK repository root. + +## Build and test + +```bash +source examples/fortran/prima/build_all.sh +python3 -m pytest -q examples/fortran/prima/tests +``` + +The example publishes `bobyqa`, `cobyla`, `lincoa`, `newuoa`, and `uobyqa` +in their native module namespaces. Required objective callbacks, optional +progress callbacks, and optional arguments inside progress callbacks are +preserved in the generated contract. + +## How the build works + +CMake compiles all 55 implementation sources once into position-independent +`libprimaf.a`. PRIK analyzes the same source universe with +[`export_symbols.txt`](export_symbols.txt), generating contracts only for the +five selected solvers and their shared callback prototypes. The wrapper build +then reads those contracts and links the existing archive. + +```text +55 Fortran sources -> libprimaf.a + \ + -> selected .pyi contract -> PRIK wrapper -> prik_prima +``` + +`PRIMA_REAL_PRECISION=64` and `PRIMA_INTEGER_KIND=0` are used for both native +compilation and contract extraction, so the contract and archive describe the +same ABI. + +## Sources and license + +The files under `native/` match the maintained Fortran target at +[libprima/prima commit `1d76fb88aeffb427cd17ed1e9d0d3b34f414913f`](https://github.com/libprima/prima/tree/1d76fb88aeffb427cd17ed1e9d0d3b34f414913f). +See [`LICENCE.txt`](LICENCE.txt) for the upstream BSD 3-Clause license. diff --git a/examples/fortran/prima/__init__.py b/examples/fortran/prima/__init__.py new file mode 100644 index 000000000..f4d48c1c7 --- /dev/null +++ b/examples/fortran/prima/__init__.py @@ -0,0 +1 @@ +"""PRIMA static-library example.""" diff --git a/examples/fortran/prima/build_all.sh b/examples/fortran/prima/build_all.sh new file mode 100755 index 000000000..336aaeec5 --- /dev/null +++ b/examples/fortran/prima/build_all.sh @@ -0,0 +1,3 @@ +source examples/fortran/prima/build_prik.sh +cd "$EXAMPLE_WORKSPACE" +export PYTHONPATH="$PRIMA_BUILD_ROOT/prik${PYTHONPATH:+:$PYTHONPATH}" diff --git a/examples/fortran/prima/build_prik.sh b/examples/fortran/prima/build_prik.sh new file mode 100755 index 000000000..ddd54e90b --- /dev/null +++ b/examples/fortran/prima/build_prik.sh @@ -0,0 +1,35 @@ +export EXAMPLE_WORKSPACE="$PWD" +export PRIMA_BUILD_ROOT="$(mktemp -d)" + +mkdir -p "$PRIMA_BUILD_ROOT/prik/generated" + +cmake \ + -S "$EXAMPLE_WORKSPACE/examples/fortran/prima" \ + -B "$PRIMA_BUILD_ROOT/native" \ + -DCMAKE_BUILD_TYPE=Release \ + -DCMAKE_Fortran_COMPILER="$(command -v gfortran)" +cmake --build "$PRIMA_BUILD_ROOT/native" --target primaf --parallel 2 + +PRIMA_SOURCES=() +while IFS= read -r source; do + PRIMA_SOURCES+=("$EXAMPLE_WORKSPACE/examples/fortran/prima/native/$source") +done < "$EXAMPLE_WORKSPACE/examples/fortran/prima/sources.txt" + +python3 -m prik generate --pyi \ + "${PRIMA_SOURCES[@]}" \ + --export-symbols "$EXAMPLE_WORKSPACE/examples/fortran/prima/export_symbols.txt" \ + --out "$PRIMA_BUILD_ROOT/contract" \ + --compiler "$(command -v gfortran)" \ + -I "$EXAMPLE_WORKSPACE/examples/fortran/prima/native/common" \ + -D PRIMA_REAL_PRECISION=64 \ + -D PRIMA_INTEGER_KIND=0 + +cd "$PRIMA_BUILD_ROOT/prik" +python3 -m prik "$PRIMA_BUILD_ROOT/contract/__init__.pyi" \ + --out prik_prima \ + --out-dir "$PRIMA_BUILD_ROOT/prik/generated" \ + --compiler "$(command -v gfortran)" \ + --native-link-item "archive:$PRIMA_BUILD_ROOT/native/libprimaf.a" \ + --native-linker-language fortran \ + -I "$PRIMA_BUILD_ROOT/native/mod" \ + --jobs 2 diff --git a/examples/fortran/prima/conftest.py b/examples/fortran/prima/conftest.py new file mode 100644 index 000000000..fb8c0c483 --- /dev/null +++ b/examples/fortran/prima/conftest.py @@ -0,0 +1,11 @@ +"""Import the PRIMA extension built by ``build_all.sh``.""" + +import importlib + +import pytest + + +@pytest.fixture(scope="session") +def prima(): + """Return the extension containing PRIMA's five public solver modules.""" + return importlib.import_module("prik_prima") diff --git a/examples/fortran/prima/export_symbols.txt b/examples/fortran/prima/export_symbols.txt new file mode 100644 index 000000000..b62e98216 --- /dev/null +++ b/examples/fortran/prima/export_symbols.txt @@ -0,0 +1,5 @@ +bobyqa_mod::bobyqa +cobyla_mod::cobyla +lincoa_mod::lincoa +newuoa_mod::newuoa +uobyqa_mod::uobyqa diff --git a/examples/fortran/prima/native/bobyqa/bobyqa.f90 b/examples/fortran/prima/native/bobyqa/bobyqa.f90 new file mode 100644 index 000000000..1621a5303 --- /dev/null +++ b/examples/fortran/prima/native/bobyqa/bobyqa.f90 @@ -0,0 +1,535 @@ +module bobyqa_mod +!--------------------------------------------------------------------------------------------------! +! BOBYQA_MOD is a module providing the reference implementation of Powell's BOBYQA algorithm in +! +! M. J. D. Powell, The BOBYQA algorithm for bound constrained optimization without derivatives, +! Technical Report DAMTP 2009/NA06, Department of Applied Mathematics and Theoretical Physics, +! Cambridge University, Cambridge, UK, 2009 +! +! BOBYQA approximately solves +! +! min F(X) subject to XL <= X <= XU, +! +! where X is a vector of variables that has N components, and F is a real-valued objective function. +! XL and XU are a pair of N-dimensional vectors indicating the lower and upper bounds of X. The +! algorithm assumes that XL < XU entrywise. It tackles the problem by applying a trust region method +! that forms quadratic models by interpolation. There is usually some freedom in the interpolation +! conditions, which is taken up by minimizing the Frobenius norm of the change to the second +! derivative of the model, beginning with the ZERO matrix. The values of the variables are +! constrained by upper and lower bounds. The arguments of the subroutine are as follows. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on the BOBYQA paper and Powell's code, with +! modernization, bug fixes, and improvements. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Thursday, February 22, 2024 PM03:30:31 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: bobyqa + + +contains + + +subroutine bobyqa(calfun, x, & + & f, xl, xu, & + & nf, rhobeg, rhoend, ftarget, maxfun, npt, iprint, & + & eta1, eta2, gamma1, gamma2, xhist, fhist, maxhist, honour_x0, callback_fcn, info) +!--------------------------------------------------------------------------------------------------! +! Among all the arguments, only CALFUN and X are obligatory. The others are OPTIONAL and you can +! neglect them unless you are familiar with the algorithm. Any unspecified optional input will take +! the default value detailed below. For instance, we may invoke the solver as follows. +! +! ! First define CALFUN and X, and then do the following. +! call bobyqa(calfun, x, f) +! +! or +! +! ! First define CALFUN, X, and XL, and then do the following. +! call bobyqa(calfun, x, f, xl = xl, rhobeg = 1.0D0, rhoend = 1.0D-6) +! +! See examples/bobyqa_exmp.f90 for a concrete example. +! +! A detailed introduction to the arguments is as follows. +! N.B.: RP and IK are defined in the module CONSTS_MOD. See consts.F90 under the directory named +! "common". By default, RP = kind(0.0D0) and IK = kind(0), with REAL(RP) being the double-precision +! real, and INTEGER(IK) being the default integer. For ADVANCED USERS, RP and IK can be defined by +! setting PRIMA_REAL_PRECISION and PRIMA_INTEGER_KIND in common/ppf.h. Use the default if unsure. +! +! CALFUN +! Input, subroutine. +! CALFUN(X, F) should evaluate the objective function at the given REAL(RP) vector X and set the +! value to the REAL(RP) scalar F. It must be provided by the user, and its definition must conform +! to the following interface: +! !-------------------------------------------------------------------------! +! subroutine calfun(x, f) +! real(RP), intent(in) :: x(:) +! real(RP), intent(out) :: f +! end subroutine calfun +! !-------------------------------------------------------------------------! +! +! X +! Input and output, REAL(RP) vector. +! As an input, X should be an N dimensional vector that contains the starting point, N being the +! dimension of the problem. As an output, X will be set to an approximate minimizer. +! +! F +! Output, REAL(RP) scalar. +! F will be set to the objective function value of X at exit. +! +! XL, XU +! Input, REAL(RP) vectors, default: XL = [], XU = []. +! XL is the lower bound for X. Its size is either N or 0, the latter signifying that X has no +! lower bound. Any entry of XL that is NaN or below -BOUNDMAX will be taken as -BOUNDMAX, which +! effectively means there is no lower bound for the corresponding entry of X. The value of +! BOUNDMAX is 0.25*HUGE(X), which is about 8.6E37 for single precision and 4.5E307 for double +! precision. XU is similar. +! N.B.: +! 1. It is required that XU - XL > 2*EPSILON(X), which is about 2.4E-7 for single precision and +! 4.5E-16 for double precision. Otherwise, the solver will return after printing a warning. +! 2. Why don't we set BOUNDMAX to REALMAX? Because we want to avoid overflow when calculating +! XU - XL and when defining/updating SU and SL. This is not a problem in MATLAB/Python/Julia/R. +! +! NF +! Output, INTEGER(IK) scalar. +! NF will be set to the number of calls of CALFUN at exit. +! +! RHOBEG, RHOEND +! Inputs, REAL(RP) scalars, default: RHOBEG = 1, RHOEND = 10^-6. RHOBEG and RHOEND must be set to +! the initial and final values of a trust-region radius, both being positive and RHOEND <= RHOBEG. +! Typically RHOBEG should be about one tenth of the greatest expected change to a variable, and +! RHOEND should indicate the accuracy that is required in the final values of the variables. +! +! FTARGET +! Input, REAL(RP) scalar, default: -Inf. +! FTARGET is the target function value. The algorithm will terminate when a point with a function +! value <= FTARGET is found. +! +! MAXFUN +! Input, INTEGER(IK) scalar, default: MAXFUN_DIM_DFT*N with MAXFUN_DIM_DFT defined in the module +! CONSTS_MOD (see common/consts.F90). MAXFUN is the maximal number of calls of CALFUN. +! +! NPT +! Input, INTEGER(IK) scalar, default: 2N + 1. +! NPT is the number of interpolation conditions for each trust region model. Its value must be in +! the interval [N+2, (N+1)(N+2)/2]. Powell commented that "the value NPT = 2*N+1 being recommended +! for a start ... much larger values tend to be inefficient, because the amount of routine work of +! each iteration is of magnitude NPT**2, and because the achievement of adequate accuracy in some +! matrix calculations becomes more difficult. Some excellent numerical results have been found in +! the case NPT=N+6 even with more than 100 variables." And "choices that exceed 2*N+1 are not +! recommended" by Powell. +! +! IPRINT +! Input, INTEGER(IK) scalar, default: 0. +! The value of IPRINT should be set to 0, 1, -1, 2, -2, 3, or -3, which controls how much +! information will be printed during the computation: +! 0: there will be no printing; +! 1: a message will be printed to the screen at the return, showing the best vector of variables +! found and its objective function value; +! 2: in addition to 1, each new value of RHO is printed to the screen, with the best vector of +! variables so far and its objective function value; +! 3: in addition to 2, each function evaluation with its variables will be printed to the screen; +! -1, -2, -3: the same information as 1, 2, 3 will be printed, not to the screen but to a file +! named BOBYQA_output.txt; the file will be created if it does not exist; the new output will +! be appended to the end of this file if it already exists. +! Note that IPRINT = +/-3 can be costly in terms of time and/or space. +! +! ETA1, ETA2, GAMMA1, GAMMA2 +! Input, REAL(RP) scalars, default: ETA1 = 0.1, ETA2 = 0.7, GAMMA1 = 0.5, and GAMMA2 = 2. +! ETA1, ETA2, GAMMA1, and GAMMA2 are parameters in the updating scheme of the trust-region radius +! detailed in the subroutine TRRAD in trustregion.f90. Roughly speaking, the trust-region radius +! is contracted by a factor of GAMMA1 when the reduction ratio is below ETA1, and enlarged by a +! factor of GAMMA2 when the reduction ratio is above ETA2. It is required that 0 < ETA1 <= ETA2 +! < 1 and 0 < GAMMA1 < 1 < GAMMA2. Normally, ETA1 <= 0.25. It is NOT advised to set ETA1 >= 0.5. +! +! XHIST, FHIST, MAXHIST +! XHIST: Output, ALLOCATABLE rank 2 REAL(RP) array; +! FHIST: Output, ALLOCATABLE rank 1 REAL(RP) array; +! MAXHIST: Input, INTEGER(IK) scalar, default: MAXFUN +! XHIST, if present, will output the history of iterates, while FHIST, if present, will output the +! history function values. MAXHIST should be a nonnegative integer, and XHIST/FHIST will output +! only the history of the last MAXHIST iterations. Therefore, MAXHIST = 0 means XHIST/FHIST will +! output nothing, while setting MAXHIST = MAXFUN requests XHIST/FHIST to output all the history. +! If XHIST is present, its size at exit will be [N, min(NF, MAXHIST)]; if FHIST is present, its +! size at exit will be min(NF, MAXHIST). +! +! IMPORTANT NOTICE: +! Setting MAXHIST to a large value can be costly in terms of memory for large problems. +! MAXHIST will be reset to a smaller value if the memory needed exceeds MAXHISTMEM defined in +! CONSTS_MOD (see consts.F90 under the directory named "common"). +! Use *HIST with caution! (N.B.: the algorithm is NOT designed for large problems). +! +! HONOUR_X0 +! Input, LOGICAL scalar, default: it is .false. if RHOBEG is present and 0 < RHOBEG < Inf, and it +! is .true. otherwise. HONOUR_X0 indicates whether to respect the user-defined X0 or not. +! BOBYQA requires that the distance between X0 and the inactive bounds is at least RHOBEG. X0 or +! RHOBEG is revised if this requirement is not met. If HONOUR_X0 == TRUE, revise RHOBEG if needed; +! otherwise, revise X0 if needed. See the PREPROC subroutine for more information. +! +! CALLBACK_FCN +! Input, function to report progress and optionally request termination. +! +! INFO +! Output, INTEGER(IK) scalar. +! INFO is the exit flag. It will be set to one of the following values defined in the module +! INFOS_MOD (see common/infos.f90): +! SMALL_TR_RADIUS: the lower bound for the trust region radius is reached; +! FTARGET_ACHIEVED: the target function value is reached; +! MAXFUN_REACHED: the objective function has been evaluated MAXFUN times; +! MAXTR_REACHED: the trust region iteration has been performed MAXTR times (MAXTR = 2*MAXFUN); +! NAN_INF_MODEL: NaN or Inf occurs in the model; +! NAN_INF_X: NaN or Inf occurs in X; +! DAMAGING_ROUNDING: the rounding error becomes damaging; +! NO_SPACE_BETWEEN_BOUNDS: there is not enough space between some lower and upper bounds, namely +! one of the difference XU(I)-XL(I) is less than 2*RHOBEG. +! !--------------------------------------------------------------------------! +! The following case(s) should NEVER occur unless there is a bug. +! NAN_INF_F: the objective function returns NaN or +Inf; +! TRSUBP_FAILED: a trust region step failed to reduce the model. +! !--------------------------------------------------------------------------! +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, TWO, HALF, TEN, TENTH, EPS, BOUNDMAX, DEBUGGING +use, non_intrinsic :: consts_mod, only : RHOBEG_DFT, RHOEND_DFT, FTARGET_DFT, MAXFUN_DIM_DFT, IPRINT_DFT +use, non_intrinsic :: debug_mod, only : assert, warning +use, non_intrinsic :: evaluate_mod, only : moderatex +use, non_intrinsic :: history_mod, only : prehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: infos_mod, only : NO_SPACE_BETWEEN_BOUNDS +use, non_intrinsic :: linalg_mod, only : trueloc +use, non_intrinsic :: memory_mod, only : safealloc +use, non_intrinsic :: pintrf_mod, only : OBJ, CALLBACK +use, non_intrinsic :: preproc_mod, only : preproc +use, non_intrinsic :: string_mod, only : num2str + +! Solver-specific modules +use, non_intrinsic :: bobyqb_mod, only : bobyqb + +implicit none + +! Compulsory arguments +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +real(RP), intent(inout) :: x(:) ! X(N) + +! Optional inputs +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in), optional :: iprint +integer(IK), intent(in), optional :: maxfun +integer(IK), intent(in), optional :: maxhist +integer(IK), intent(in), optional :: npt +logical, intent(in), optional :: honour_x0 +real(RP), intent(in), optional :: eta1 +real(RP), intent(in), optional :: eta2 +real(RP), intent(in), optional :: ftarget +real(RP), intent(in), optional :: gamma1 +real(RP), intent(in), optional :: gamma2 +real(RP), intent(in), optional :: rhobeg +real(RP), intent(in), optional :: rhoend +real(RP), intent(in), optional :: xl(:) ! XL(N) +real(RP), intent(in), optional :: xu(:) ! XU(N) + +! Optional outputs +integer(IK), intent(out), optional :: info +integer(IK), intent(out), optional :: nf +real(RP), intent(out), optional :: f +real(RP), intent(out), optional, allocatable :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out), optional, allocatable :: xhist(:, :) ! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'BOBYQA' +character(len=*), parameter :: srname = 'BOBYQA' +integer(IK) :: info_loc +integer(IK) :: iprint_loc +integer(IK) :: k +integer(IK) :: maxfun_loc +integer(IK) :: maxhist_loc +integer(IK) :: n +integer(IK) :: nf_loc +integer(IK) :: nhist +integer(IK) :: npt_loc +logical :: has_rhobeg +logical :: honour_x0_loc +real(RP) :: eta1_loc +real(RP) :: eta2_loc +real(RP) :: f_loc +real(RP) :: ftarget_loc +real(RP) :: gamma1_loc +real(RP) :: gamma2_loc +real(RP) :: rhobeg_loc +real(RP) :: rhoend_loc +real(RP) :: xl_loc(size(x)) +real(RP) :: xu_loc(size(x)) +real(RP), allocatable :: fhist_loc(:) ! FHIST_LOC(MAXFHIST) +real(RP), allocatable :: xhist_loc(:, :) ! XHIST_LOC(N, MAXXHIST) + +! Sizes +n = int(size(x), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + if (present(xl)) then + call assert(size(xl) == n .or. size(xl) == 0, 'SIZE(XL) == N unless XL is empty', srname) + end if + if (present(xu)) then + call assert(size(xu) == n .or. size(xu) == 0, 'SIZE(XU) == N unless XU is empty', srname) + end if +end if + +! Read the inputs + +xl_loc = -BOUNDMAX +if (present(xl)) then + if (size(xl) > 0) then + xl_loc = xl + end if +end if +xl_loc(trueloc(is_nan(xl_loc) .or. xl_loc < -BOUNDMAX)) = -BOUNDMAX + +xu_loc = BOUNDMAX +if (present(xu)) then + if (size(xu) > 0) then + xu_loc = xu + end if +end if +xu_loc(trueloc(is_nan(xu_loc) .or. xu_loc > BOUNDMAX)) = BOUNDMAX + +! The solver requires that MINVAL(XU-XL) >= 2*RHOBEG, and we return if MINVAL(XU-XL) < 2*EPS. +! It would be better to fix the variables at (XU+XL)/2 wherever XU and XL almost equal, as is done +! in the MATLAB/Python interface of the solvers. In Fortran, this is doable using internal functions, +! but we choose not to implement it in the current version. +if (any(xu_loc - xl_loc < TWO * EPS)) then + if (present(info)) then + info = NO_SPACE_BETWEEN_BOUNDS + end if + call warning(solver, 'There is no space between the lower and upper bounds of variable '// & + & num2str(minval(trueloc(xu_loc - xl_loc < TWO * EPS)))//'. The solver cannot continue') + return +end if + +x = max(xl_loc, min(xu_loc, moderatex(x))) + +! If RHOBEG is present, then RHOBEG_LOC is a copy of RHOBEG; otherwise, RHOBEG_LOC takes the default +! value for RHOBEG, taking the value of RHOEND into account. Note that RHOEND is considered only if +! it is present and it is VALID (i.e., finite and positive). The other inputs are read similarly. +if (present(rhobeg)) then + rhobeg_loc = rhobeg +elseif (present(rhoend)) then + ! Fortran does not take short-circuit evaluation of logic expressions. Thus it is WRONG to + ! combine the evaluation of PRESENT(RHOEND) and the evaluation of IS_FINITE(RHOEND) as + ! "IF (PRESENT(RHOEND) .AND. IS_FINITE(RHOEND))". The compiler may choose to evaluate the + ! IS_FINITE(RHOEND) even if PRESENT(RHOEND) is false! + if (is_finite(rhoend) .and. rhoend > 0) then + rhobeg_loc = max(TEN * rhoend, RHOBEG_DFT) + else + rhobeg_loc = RHOBEG_DFT + end if +else + rhobeg_loc = RHOBEG_DFT +end if + +if (present(rhoend)) then + rhoend_loc = rhoend +elseif (rhobeg_loc > 0) then + rhoend_loc = max(EPS, min((RHOEND_DFT / RHOBEG_DFT) * rhobeg_loc, RHOEND_DFT)) +else + rhoend_loc = RHOEND_DFT +end if + +if (present(ftarget)) then + ftarget_loc = ftarget +else + ftarget_loc = FTARGET_DFT +end if + +if (present(maxfun)) then + maxfun_loc = maxfun +else + maxfun_loc = MAXFUN_DIM_DFT * n +end if + +if (present(npt)) then + npt_loc = npt +elseif (maxfun_loc >= n + 3_IK) then ! Take MAXFUN into account if it is valid. + npt_loc = min(maxfun_loc - 1_IK, 2_IK * n + 1_IK) +else + npt_loc = 2_IK * n + 1_IK +end if + +if (present(iprint)) then + iprint_loc = iprint +else + iprint_loc = IPRINT_DFT +end if + +if (present(eta1)) then + eta1_loc = eta1 +elseif (present(eta2)) then + if (eta2 > 0 .and. eta2 < 1) then + eta1_loc = max(EPS, eta2 / 7.0_RP) + end if +else + eta1_loc = TENTH +end if + +if (present(eta2)) then + eta2_loc = eta2 +elseif (eta1_loc > 0 .and. eta1_loc < 1) then + eta2_loc = (eta1_loc + TWO) / 3.0_RP +else + eta2_loc = 0.7_RP +end if + +if (present(gamma1)) then + gamma1_loc = gamma1 +else + gamma1_loc = HALF +end if + +if (present(gamma2)) then + gamma2_loc = gamma2 +else + gamma2_loc = TWO +end if + +if (present(maxhist)) then + maxhist_loc = maxhist +else + maxhist_loc = maxval([maxfun_loc, n + 3_IK, MAXFUN_DIM_DFT * n]) +end if + +has_rhobeg = present(rhobeg) +honour_x0_loc = .true. +if (present(honour_x0)) then + honour_x0_loc = honour_x0 +else if (has_rhobeg) then + ! HONOUR_X0 is FALSE if user provides a valid RHOBEG. Is this the best choice? + honour_x0_loc = (.not. (is_finite(rhobeg) .and. rhobeg > 0)) +end if + + +! Preprocess the inputs in case some of them are invalid. It does nothing if all inputs are valid. +call preproc(solver, n, iprint_loc, maxfun_loc, maxhist_loc, ftarget_loc, rhobeg_loc, rhoend_loc, & + & npt=npt_loc, eta1=eta1_loc, eta2=eta2_loc, gamma1=gamma1_loc, gamma2=gamma2_loc, & + & has_rhobeg=has_rhobeg, honour_x0=honour_x0_loc, xl=xl_loc, xu=xu_loc, x0=x) + +! Further revise MAXHIST_LOC according to MAXHISTMEM, and allocate memory for the history. +! In MATLAB/Python/Julia/R implementation, we should simply set MAXHIST = MAXFUN and initialize +! FHIST = NaN(1, MAXFUN), XHIST = NaN(N, MAXFUN) +! if they are requested; replace MAXFUN with 0 for the history that is not requested. +call prehist(maxhist_loc, n, present(xhist), xhist_loc, present(fhist), fhist_loc) + + +!-------------------- Call BOBYQB, which performs the real calculations. --------------------------! +if (present(callback_fcn)) then + call bobyqb(calfun, iprint_loc, maxfun_loc, npt_loc, eta1_loc, eta2_loc, ftarget_loc, & + & gamma1_loc, gamma2_loc, rhobeg_loc, rhoend_loc, xl_loc, xu_loc, x, nf_loc, f_loc, & + & fhist_loc, xhist_loc, info_loc, callback_fcn) +else + call bobyqb(calfun, iprint_loc, maxfun_loc, npt_loc, eta1_loc, eta2_loc, ftarget_loc, & + & gamma1_loc, gamma2_loc, rhobeg_loc, rhoend_loc, xl_loc, xu_loc, x, nf_loc, f_loc, & + & fhist_loc, xhist_loc, info_loc) +end if +!--------------------------------------------------------------------------------------------------! + +! Write the outputs. + +if (present(f)) then + f = f_loc +end if + +if (present(nf)) then + nf = nf_loc +end if + +if (present(info)) then + info = info_loc +end if + +! Copy XHIST_LOC to XHIST if needed. +if (present(xhist)) then + nhist = min(nf_loc, int(size(xhist_loc, 2), IK)) + !----------------------------------------------------! + call safealloc(xhist, n, nhist) ! Removable in F2003. + !----------------------------------------------------! + xhist = xhist_loc(:, 1:nhist) + ! N.B.: + ! 0. Allocate XHIST as long as it is present, even if the size is 0; otherwise, it will be + ! illegal to enquire XHIST after exit. + ! 1. Even though Fortran 2003 supports automatic (re)allocation of allocatable arrays upon + ! intrinsic assignment, we keep the line of SAFEALLOC, because some very new compilers (Absoft + ! Fortran 21.0) are still not standard-compliant in this respect. + ! 2. NF may not be present. Hence we should NOT use NF but NF_LOC. + ! 3. When SIZE(XHIST_LOC, 2) > NF_LOC, which is the normal case in practice, XHIST_LOC contains + ! GARBAGE in XHIST_LOC(:, NF_LOC + 1 : END). Therefore, we MUST cap XHIST at NF_LOC so that + ! XHIST contains only valid history. For this reason, there is no way to avoid allocating + ! two copies of memory for XHIST unless we declare it to be a POINTER instead of ALLOCATABLE. +end if +! F2003 automatically deallocate local ALLOCATABLE variables at exit, yet we prefer to deallocate +! them immediately when they finish their jobs. +deallocate (xhist_loc) + +! Copy FHIST_LOC to FHIST if needed. +if (present(fhist)) then + nhist = min(nf_loc, int(size(fhist_loc), IK)) + !--------------------------------------------------! + call safealloc(fhist, nhist) ! Removable in F2003. + !--------------------------------------------------! + fhist = fhist_loc(1:nhist) ! The same as XHIST, we must cap FHIST at NF_LOC. +end if +deallocate (fhist_loc) + +! If NF_LOC > MAXHIST_LOC, warn that not all history is recorded. +if ((present(xhist) .or. present(fhist)) .and. maxhist_loc < nf_loc) then + call warning(solver, 'Only the history of the last '//num2str(maxhist_loc)//' function evaluation(s) is recorded') +end if + +! Postconditions +if (DEBUGGING) then + call assert(nf_loc <= maxfun_loc, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + nhist = min(nf_loc, maxhist_loc) + if (present(xhist)) then + call assert(size(xhist, 1) == n .and. size(xhist, 2) == nhist, 'SIZE(XHIST) == [N, NHIST]', srname) + call assert(.not. any(is_nan(xhist)), 'XHIST does not contain NaN', srname) + end if + + if (present(xl)) then + if (size(xl) == size(x)) then + call assert(all(x >= xl), 'X >= XL', srname) + if (present(xhist)) then + do k = 1, nhist + call assert(all(xhist(:, k) >= xl), 'XHIST >= XL', srname) + end do + end if + end if + end if + + if (present(xu)) then + if (size(xu) == size(x)) then + call assert(all(x <= xu), 'X <= XU', srname) + if (present(xhist)) then + do k = 1, nhist + call assert(all(xhist(:, k) <= xu), 'XHIST <= XU', srname) + end do + end if + end if + end if + + if (present(fhist)) then + call assert(size(fhist) == nhist, 'SIZE(FHIST) == NHIST', srname) + call assert(.not. any(is_nan(fhist) .or. is_posinf(fhist)), 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(fhist < f_loc), 'F is the smallest in FHIST', srname) + end if +end if + +end subroutine bobyqa + + +end module bobyqa_mod diff --git a/examples/fortran/prima/native/bobyqa/bobyqb.f90 b/examples/fortran/prima/native/bobyqa/bobyqb.f90 new file mode 100644 index 000000000..9d14c9d2a --- /dev/null +++ b/examples/fortran/prima/native/bobyqa/bobyqb.f90 @@ -0,0 +1,784 @@ +! TODO: +! 1. Improve RESCUE so that it accepts an [XNEW, FNEW] that is not interpolated yet, or even accepts +! [XRESERVE, FRESERVE], which contains points that have been evaluated. +! +module bobyqb_mod +!--------------------------------------------------------------------------------------------------! +! This module performs the major calculations of BOBYQA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the BOBYQA paper. +! +! N.B. (Zaikun 20230312): In Powell's code, the strategy concerning RESCUE is a bit complex. +! +! 1. Suppose that a trust-region step D is calculated. Powell's code sets KNEW_TR before evaluating +! F at the trial point XOPT+D, assuming that the value of F at this point is not better than the +! current FOPT. With this KNEW_TR, the denominator of the update is calculated. If this denominator +! is sufficiently large, then evaluate F at XOPT+D, recalculate KNEW_TR if the function value turns +! out better than FOPT, and perform the update to include XOPT+D in the interpolation. If the +! denominator is not sufficiently large, then RESCUE is called, and another trust-region step is +! taken immediately after, discarding the previously calculated trust-region step D. +! +! 2. Suppose that a geometry step D is calculated. Then KNEW_GEO must have been set before. Powell's +! code then calculates the denominator of the update. If the denominator is sufficiently large, then +! evaluate F at XOPT+D, and perform the update. If the denominator is not sufficiently large, then +! RESCUE is called; if RESCUE does not evaluate F at any new point (allowed by Powell's code but not +! ours), then take a new geometry step, or else take a trust-region step, discarding the previously +! calculated geometry step D in both cases. +! +! 3. If it turns out necessary to call RESCUE again, but no new function value has been evaluated +! after the last RESCUE, then Powell's code will terminate. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Wed 08 Apr 2026 06:38:40 PM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: bobyqb + + +contains + + +subroutine bobyqb(calfun, iprint, maxfun, npt, eta1, eta2, ftarget, gamma1, gamma2, rhobeg, rhoend, & + & xl, xu, x, nf, f, fhist, xhist, info, callback_fcn) +!--------------------------------------------------------------------------------------------------! +! This subroutine performs the major calculations of BOBYQA. +! +! IPRINT, MAXFUN, MAXHIST, NPT, ETA1, ETA2, FTARGET, GAMMA1, GAMMA2, RHOBEG, RHOEND, XL, XU, X, NF, +! F, FHIST, XHIST, and INFO are identical to the corresponding arguments in subroutine BOBYQA. +! +! XBASE holds a shift of origin that should reduce the contributions from rounding errors to values +! of the model and Lagrange functions. +! SL and SU hold XL - XBASE and XU - XBASE, respectively. +! XOPT is the displacement from XBASE of the best vector of variables so far (i.e., the one provides +! the least calculated F so far). XOPT satisfies SL(I) <= XOPT(I) <= SU(I), with appropriate +! equalities when XOPT is on a constraint boundary. FOPT = F(XOPT + XBASE). However, we do not +! save XOPT and FOPT explicitly, because XOPT = XPT(:, KOPT) and FOPT = FVAL(KOPT), which is +! explained below. +! [XPT, FVAL, KOPT] describes the interpolation set: +! XPT contains the interpolation points relative to XBASE, each COLUMN for a point; FVAL holds the +! values of F at the interpolation points; KOPT is the index of XOPT in XPT. +! [GOPT, HQ, PQ] describes the quadratic model: GOPT will hold the gradient of the quadratic model +! at XBASE + XOPT; HQ will hold the explicit second order derivatives of the quadratic model; PQ +! will contain the parameters of the implicit second order derivatives of the quadratic model. +! [BMAT, ZMAT] describes the matrix H in the BOBYQA paper (eq. 2.7), which is the inverse of +! the coefficient matrix of the KKT system for the least-Frobenius norm interpolation problem: +! ZMAT will hold a factorization of the leading NPT*NPT submatrix of H, the factorization being +! OMEGA = ZMAT*ZMAT^T, which provides both the correct rank and positive semi-definiteness. BMAT +! will hold the last N ROWs of H except for the (NPT+1)th column. Note that the (NPT + 1)th row +! and column of H are not saved as they are unnecessary for the calculation. +! D is reserved for trial steps from XOPT. It is chosen by subroutine TRSBOX or GEOSTEP. Usually +! XBASE + XOPT + D is the vector of variables for the next call of CALFUN. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, TEN, TENTH, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert!, wassert, validate +use, non_intrinsic :: evaluate_mod, only : evaluate +use, non_intrinsic :: history_mod, only : savehist, rangehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: infos_mod, only : INFO_DFT, SMALL_TR_RADIUS, MAXTR_REACHED, DAMAGING_ROUNDING,& + & NAN_INF_MODEL, CALLBACK_TERMINATE +use, non_intrinsic :: linalg_mod, only : norm +use, non_intrinsic :: message_mod, only : retmsg, rhomsg, fmsg +use, non_intrinsic :: pintrf_mod, only : OBJ, CALLBACK +use, non_intrinsic :: powalg_mod, only : quadinc, calden, calvlag!, errquad +use, non_intrinsic :: ratio_mod, only : redrat +use, non_intrinsic :: redrho_mod, only : redrho +use, non_intrinsic :: shiftbase_mod, only : shiftbase +use, non_intrinsic :: xinbd_mod, only : xinbd + +! Solver-specific modules +use, non_intrinsic :: geometry_bobyqa_mod, only : geostep, setdrop_tr +use, non_intrinsic :: initialize_bobyqa_mod, only : initxf, initq, inith +use, non_intrinsic :: rescue_mod, only : rescue +use, non_intrinsic :: trustregion_bobyqa_mod, only : trsbox, trrad +use, non_intrinsic :: update_bobyqa_mod, only : updatexf, updateq, tryqalt, updateh + +implicit none + +! Inputs +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfun +integer(IK), intent(in) :: npt +real(RP), intent(in) :: eta1 +real(RP), intent(in) :: eta2 +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: gamma1 +real(RP), intent(in) :: gamma2 +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: rhoend +real(RP), intent(in) :: xl(:) ! XL(N) +real(RP), intent(in) :: xu(:) ! XU(N) + +! In-outputs +real(RP), intent(inout) :: x(:) ! X(N) + +! Outputs +integer(IK), intent(out) :: info +integer(IK), intent(out) :: nf +real(RP), intent(out) :: f +real(RP), intent(out) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out) :: xhist(:, :) ! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'BOBYQA' +character(len=*), parameter :: srname = 'BOBYQB' +integer(IK) :: ij(2, max(0_IK, int(npt - 2 * size(x) - 1, IK))) +integer(IK) :: itest +integer(IK) :: k +integer(IK) :: knew_geo +integer(IK) :: knew_tr +integer(IK) :: kopt +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxtr +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: subinfo +integer(IK) :: tr +logical :: accurate_mod +logical :: adequate_geo +logical :: bad_trstep +logical :: close_itpset +logical :: improve_geo +logical :: reduce_rho +logical :: rescued +logical :: shortd +logical :: small_trrad +logical :: terminate +logical :: to_rescue +logical :: trfail +logical :: ximproved +real(RP) :: bmat(size(x), npt + size(x)) +real(RP) :: crvmin +real(RP) :: d(size(x)) +real(RP) :: delbar +real(RP) :: delta +real(RP) :: den(npt) +real(RP) :: distsq(npt) +real(RP) :: dnorm +real(RP) :: dnorm_rec(2) ! Powell's implementation: DNORM_REC(3) +real(RP) :: ebound +real(RP) :: fval(npt) +real(RP) :: gamma3 +real(RP) :: gopt(size(x)) +real(RP) :: hq(size(x), size(x)) +real(RP) :: moderr +real(RP) :: moderr_rec(size(dnorm_rec)) +real(RP) :: pq(npt) +real(RP) :: qred +real(RP) :: ratio +real(RP) :: rho +real(RP) :: sl(size(x)) +real(RP) :: su(size(x)) +real(RP) :: vlag(npt + size(x)) +real(RP) :: xbase(size(x)) +real(RP) :: xdrop(size(x)) +real(RP) :: xosav(size(x)) +real(RP) :: xpt(size(x), npt) +real(RP) :: zmat(npt, npt - size(x) - 1) +real(RP), parameter :: trtol = 1.0E-2_RP ! Convergence tolerance of trust-region subproblem solver + +! Sizes. +n = int(size(x), kind(n)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxhist = int(max(maxxhist, maxfhist), kind(maxhist)) + +! Preconditions +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(npt >= n + 2, 'NPT >= N+2', srname) + call assert(maxfun >= npt + 1, 'MAXFUN >= NPT+1', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + call assert(rhobeg >= rhoend .and. rhoend > 0, 'RHOBEG >= RHOEND > 0', srname) + call assert(size(xl) == n .and. size(xu) == n, 'SIZE(XL) == N == SIZE(XU)', srname) + call assert(all(rhobeg <= (xu - xl) / TWO), 'RHOBEG <= MINVAL(XU-XL)/2', srname) + call assert(all(is_finite(x)), 'X is finite', srname) + call assert(all(x >= xl .and. (x <= xl .or. x - xl >= rhobeg)), 'X == XL or X - XL >= RHOBEG', srname) + call assert(all(x <= xu .and. (x >= xu .or. xu - x >= rhobeg)), 'X == XU or XU - X >= RHOBEG', srname) + call assert(maxhist >= 0 .and. maxhist <= maxfun, '0 <= MAXHIST <= MAXFUN', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialize XBASE, XPT, SL, SU, FVAL, and KOPT, together with the history, NF, and IJ. +call initxf(calfun, iprint, maxfun, ftarget, rhobeg, xl, xu, x, ij, kopt, nf, fhist, fval, & + & sl, su, xbase, xhist, xpt, subinfo) + +! Report the current best value, and check if user asks for early termination. +terminate = .false. +if (present(callback_fcn)) then + call callback_fcn(xbase + xpt(:, kopt), fval(kopt), nf, 0_IK, terminate=terminate) + if (terminate) then + subinfo = CALLBACK_TERMINATE + end if +end if + +! Initialize X and F according to KOPT. +x = xinbd(xbase, xpt(:, kopt), xl, xu, sl, su) ! In precise arithmetic, X = XBASE + XOPT. +f = fval(kopt) + +! Finish the initialization if INITXF completed normally and CALLBACK did not request termination; +! otherwise, do not proceed, as XPT etc may be uninitialized, leading to errors or exceptions. +if (subinfo == INFO_DFT) then + ! Initialize [BMAT, ZMAT], representing inverse of KKT matrix of the interpolation system. + call inith(ij, xpt, bmat, zmat) + + ! Initialize the quadratic represented by [GOPT, HQ, PQ], so that its gradient at XBASE+XOPT is + ! GOPT; its Hessian is HQ + sum_{K=1}^NPT PQ(K)*XPT(:, K)*XPT(:, K)'. + call initq(ij, fval, xpt, gopt, hq, pq) + if (.not. (all(is_finite(gopt)) .and. all(is_finite(hq)) .and. all(is_finite(pq)))) then + subinfo = NAN_INF_MODEL + end if +end if + +! Check whether to return due to abnormal cases that may occur during the initialization. +if (subinfo /= INFO_DFT) then + info = subinfo + ! Arrange FHIST and XHIST so that they are in the chronological order. + call rangehist(nf, xhist, fhist) + ! Print a return message according to IPRINT. + call retmsg(solver, info, iprint, nf, f, x) + ! Postconditions + if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(all(x >= xl) .and. all(x <= xu), 'XL <= X <= XU', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + do k = 1, min(nf, maxxhist) + call assert(all(xhist(:, k) >= xl) .and. all(xhist(:, k) <= xu), 'XL <= XHIST <= XU', srname) + end do + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(fhist(1:min(nf, maxfhist)) < f), 'F is the smallest in FHIST', srname) + end if + return +end if + +! Set some more initial values. +! We must initialize RATIO. Otherwise, when SHORTD = TRUE, compilers may raise a run-time error that +! RATIO is undefined. But its value will not be used: when SHORTD = FALSE, its value will be +! overwritten; when SHORTD = TRUE, its value is used only in BAD_TRSTEP, which is TRUE regardless of +! RATIO. Similar for KNEW_TR. +! No need to initialize SHORTD unless MAXTR < 1, but some compilers may complain if we do not do it. +rho = rhobeg +delta = rho +ebound = ZERO +rescued = .false. +shortd = .false. +trfail = .false. +ratio = -ONE +dnorm_rec = REALMAX +moderr_rec = REALMAX +knew_tr = 0 +knew_geo = 0 +itest = 0 + +! If DELTA <= GAMMA3*RHO after an update, we set DELTA to RHO. GAMMA3 must be less than GAMMA2. The +! reason is as follows. Imagine a very successful step with DENORM = the un-updated DELTA = RHO. +! Then TRRAD will update DELTA to GAMMA2*RHO. If GAMMA3 >= GAMMA2, then DELTA will be reset to RHO, +! which is not reasonable as D is very successful. See paragraph two of Sec. 5.2.5 in +! T. M. Ragonneau's thesis: "Model-Based Derivative-Free Optimization Methods and Software". +! According to test on 20230613, for BOBYQA, this Powellful updating scheme of DELTA works better +! than setting directly DELTA = MAX(NEW_DELTA, RHO). +gamma3 = max(ONE, min(0.75_RP * gamma2, 1.5_RP)) + +! MAXTR is the maximal number of trust-region iterations. Here, we set it to HUGE(MAXTR) - 1 so that +! the algorithm will not terminate due to MAXTR. However, this may not be allowed in other languages +! such as MATLAB. In that case, we can set MAXTR to 10*MAXFUN, which is unlikely to reach because +! each trust-region iteration takes 1 or 2 function evaluations unless the trust-region step is short +! or fails to reduce the trust-region model but the geometry step is not invoked. +! N.B.: Do NOT set MAXTR to HUGE(MAXTR), as it may cause overflow and infinite cycling in the DO +! loop. See +! https://fortran-lang.discourse.group/t/loop-variable-reaching-integer-huge-causes-infinite-loop +! https://fortran-lang.discourse.group/t/loops-dont-behave-like-they-should +maxtr = huge(maxtr) - 1_IK !!MATLAB: maxtr = 10 * maxfun; +info = MAXTR_REACHED + +! Begin the iterative procedure. +! After solving a trust-region subproblem, we use three boolean variables to control the workflow. +! SHORTD: Is the trust-region trial step too short to invoke a function evaluation? +! IMPROVE_GEO: Should we improve the geometry? +! REDUCE_RHO: Should we reduce rho? +! BOBYQA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. +do tr = 1, maxtr + ! Generate the next trust region step D. + call trsbox(delta, gopt, hq, pq, sl, su, trtol, xpt(:, kopt), xpt, crvmin, d) + dnorm = min(delta, norm(d)) + shortd = (dnorm <= HALF * rho) ! `<=` works better than `<` in case of underflow. + + ! Set QRED to the reduction of the quadratic model when the move D is made from XOPT. QRED + ! should be positive. If it is nonpositive due to rounding errors, we will not take this step. + qred = -quadinc(d, xpt, gopt, pq, hq) ! QRED = Q(XOPT) - Q(XOPT + D) + trfail = (.not. qred > 1.0E-6 * rho**2) ! QRED is tiny/negative or NaN. + + ! When D is short, make a choice between reducing RHO and improving the geometry depending + ! on whether or not our work with the current RHO seems complete. RHO is reduced if the + ! errors in the quadratic model at the recent interpolation points compare favourably + ! with predictions of likely improvements to the model within distance HALF*RHO of XOPT. + ! Why do we reduce RHO when SHORTD is true and the entries of MODERR_REC and DNORM_REC are all + ! small? The reason is well explained by the BOBYQA paper in the paragraphs surrounding + ! (6.8)--(6.11). Roughly speaking, in this case, a trust-region step is unlikely to decrease the + ! objective function according to some estimations. This suggests that the current trust-region + ! center may be an approximate local minimizer up to the current "resolution" of the algorithm. + ! When this occurs, the algorithm takes the view that the work for the current RHO is complete, + ! and hence it will reduce RHO, which will enhance the resolution of the algorithm in general. + if (shortd .or. trfail) then + delta = TENTH * delta + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + ! Evaluate EBOUND. It will be used as a bound to test if the entries of MODERR_REC are small. + ebound = errbd(crvmin, d, gopt, hq, moderr_rec, pq, rho, sl, su, xpt(:, kopt), xpt) + else + ! Calculate the next value of the objective function. + x = xinbd(xbase, xpt(:, kopt) + d, xl, xu, sl, su) ! X = XBASE + XOPT + D without rounding. + call evaluate(calfun, x, f) + nf = nf + 1_IK + rescued = .false. ! Set RESCUED to FALSE after evaluating F at a new point. + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Trust region', iprint, nf, delta, f, x) + ! Save X, F into the history. + call savehist(nf, x, xhist, f, fhist) + + ! Check whether to exit + subinfo = checkexit(maxfun, nf, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + + ! Update DNORM_REC and MODERR_REC. + ! DNORM_REC records the DNORM of the recent function evaluations with the current RHO. + dnorm_rec = [dnorm_rec(2:size(dnorm_rec)), dnorm] + ! MODERR is the error of the current model in predicting the change in F due to D. + ! MODERR_REC records the prediction errors of the recent models with the current RHO. + moderr = f - fval(kopt) + qred + moderr_rec = [moderr_rec(2:size(moderr_rec)), moderr] + + ! Calculate the reduction ratio by REDRAT, which handles Inf/NaN carefully. + ratio = redrat(fval(kopt) - f, qred, eta1) + + ! Update DELTA. After this, DELTA < DNORM may hold. + delta = trrad(delta, dnorm, eta1, eta2, gamma1, gamma2, ratio) + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + + ! Is the newly generated X better than current best point? + ximproved = (f < fval(kopt)) + + ! Call RESCUE if rounding errors have damaged the denominator corresponding to D. + ! RESCUE is invoked sometimes though not often after a trust-region step, and it does + ! improve the performance, especially when pursing high-precision solutions. + vlag = calvlag(kopt, bmat, d, xpt, zmat) + den = calden(kopt, bmat, d, xpt, zmat) + to_rescue = (ximproved .and. .not. (is_finite(sum(abs(vlag))) .and. any(den > maxval(vlag(1:npt)**2)))) + ! Below are some alternatives conditions for calling RESCUE. They perform fairly well. + ! !to_rescue = .false. ! Do not call RESCUE at all. + ! !to_rescue = (ximproved .and. .not. any(den > 0.25_RP * maxval(vlag(1:npt)**2))) + ! !to_rescue = (ximproved .and. .not. any(den > HALF * maxval(vlag(1:npt)**2))) + ! !to_rescue = (.not. any(den > HALF * maxval(vlag(1:npt)**2))) ! Powell's code. + ! !to_rescue = (.not. any(den > maxval(vlag(1:npt)**2))) + if (to_rescue) then + if (rescued) then + info = DAMAGING_ROUNDING ! The last RESCUE did not improve the situation. + exit + end if + call rescue(calfun, solver, iprint, maxfun, delta, ftarget, xl, xu, kopt, nf, fhist, & + & fval, gopt, hq, pq, sl, su, xbase, xhist, xpt, bmat, zmat, subinfo) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + rescued = .true. + dnorm_rec = REALMAX + moderr_rec = REALMAX + + ! RESCUE shifts XBASE to the best point before RESCUE. Update D, MODERR, and XIMPROVED. + ! Do NOT calculate QRED according to this D, as it is not really a trust region step. + ! Note that QRED will be used afterward for defining IMPROVE_GEO and REDUCE_RHO. + d = max(sl, min(su, d)) - xpt(:, kopt) + moderr = f - fval(kopt) - quadinc(d, xpt, gopt, pq, hq) + ximproved = (f < fval(kopt)) + end if + + ! Set KNEW_TR to the index of the interpolation point to be replaced with XOPT + D. + ! KNEW_TR will ensure that the geometry of XPT is "good enough" after the replacement. + knew_tr = setdrop_tr(kopt, ximproved, bmat, d, delta, rho, xpt, zmat) + + ! Update [BMAT, ZMAT] (representing H in the BOBYQA paper), [GQ, HQ, PQ] (the quadratic + ! model), and [FVAL, XPT, KOPT, FOPT, XOPT] so that XPT(:, KNEW_TR) becomes XOPT + D. If + ! KNEW_TR = 0, the updating subroutines will do essentially nothing, as the algorithm + ! decides not to include XOPT + D into XPT. + if (knew_tr > 0) then + xdrop = xpt(:, knew_tr) + xosav = xpt(:, kopt) + call updateh(knew_tr, kopt, d, xpt, bmat, zmat) + call updatexf(knew_tr, ximproved, f, max(sl, min(su, xosav + d)), kopt, fval, xpt) + call updateq(knew_tr, ximproved, bmat, d, moderr, xdrop, xosav, xpt, zmat, gopt, hq, pq) + ! Try whether to replace the new quadratic model with the alternative model, namely the + ! least Frobenius norm interpolant. + call tryqalt(bmat, fval - fval(kopt), ratio, sl, su, xpt(:, kopt), xpt, zmat, itest, gopt, hq, pq) + if (.not. (all(is_finite(gopt)) .and. all(is_finite(hq)) .and. all(is_finite(pq)))) then + info = NAN_INF_MODEL + exit + end if + end if + end if ! End of IF (SHORTD .OR. TRFAIL). The normal trust-region calculation ends. + + + !----------------------------------------------------------------------------------------------! + ! Before the next trust-region iteration, we may improve the geometry of XPT or reduce RHO + ! according to IMPROVE_GEO and REDUCE_RHO, which in turn depend on the following indicators. + ! N.B.: We must ensure that the algorithm does not set IMPROVE_GEO = TRUE at infinitely many + ! consecutive iterations without moving XOPT or reducing RHO. Otherwise, the algorithm will get + ! stuck in repetitive invocations of GEOSTEP. To this end, make sure the following. + ! 1. The threshold for CLOSE_ITPSET is at least DELBAR, the trust region radius for GEOSTEP. + ! Normally, DELBAR <= DELTA <= the threshold (In Powell's UOBYQA, DELBAR = RHO < the threshold). + ! 2. If an iteration sets IMPROVE_GEO = TRUE, it must also reduce DELTA or set DELTA to RHO. + + ! ACCURATE_MOD: Are the recent models sufficiently accurate? Used only if SHORTD is TRUE. + accurate_mod = all(abs(moderr_rec) <= ebound) .and. all(dnorm_rec <= rho) + ! CLOSE_ITPSET: Are the interpolation points close to XOPT? + distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - xpt(:, kopt)).^2) % Implicit expansion + close_itpset = all(distsq <= max(delta**2, (TEN * rho)**2)) + ! Below are some alternative definitions of CLOSE_ITPSET. + ! N.B.: The threshold for CLOSE_ITPSET is at least DELBAR, the trust region radius for GEOSTEP. + ! !close_itpset = all(distsq <= max((TWO * delta)**2, (TEN * rho)**2)) ! Powell's code. + ! !close_itpset = all(distsq <= 4.0_RP * delta**2) ! Powell's NEWUOA code. + ! !close_itpset = all(distsq <= max(delta**2, 4.0_RP * rho**2)) ! Powell's LINCOA code. + ! ADEQUATE_GEO: Is the geometry of the interpolation set "adequate"? + ! N.B. (Zaikun 20240314): Even if RESCUE has just been called (RESCUED = TRUE), the geometry may + ! still be inadequate/improvable if XPT contains points far away from XOPT. + adequate_geo = (shortd .and. accurate_mod) .or. close_itpset + ! SMALL_TRRAD: Is the trust-region radius small? This indicator seems not impactive in practice. + small_trrad = (max(delta, dnorm) <= rho) ! Powell's code. See also (6.7) of the BOBYQA paper. + !small_trrad = (delsav <= rho) ! Behaves the same as Powell's version. DELSAV = unupdated DELTA. + + ! IMPROVE_GEO and REDUCE_RHO are defined as follows. + ! N.B.: If SHORTD is TRUE at the very first iteration, then REDUCE_RHO will be set to TRUE. + ! Powell's code does not have TRFAIL in BAD_TRSTEP; it terminates if TRFAIL is TRUE. + + ! BAD_TRSTEP (for IMPROVE_GEO): Is the last trust-region step bad? + bad_trstep = (shortd .or. trfail .or. ratio <= eta1 .or. knew_tr == 0) + improve_geo = bad_trstep .and. .not. adequate_geo ! See the text above (6.7) of the BOBYQA paper. + ! BAD_TRSTEP (for REDUCE_RHO): Is the last trust-region step bad? + bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) + reduce_rho = bad_trstep .and. adequate_geo .and. small_trrad ! See (6.7) of the BOBYQA paper. + ! Zaikun 20221111: What if RESCUE has been called? Is it still reasonable to use RATIO? + ! Zaikun 20221127: If RESCUE has been called, then KNEW_TR may be 0 even if RATIO > 0. + + ! Equivalently, REDUCE_RHO can be set as follows. It shows that REDUCE_RHO is TRUE in two cases. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) + ! !reduce_rho = (shortd .and. accurate_mod) .or. (bad_trstep .and. close_itpset .and. small_trrad) + + ! With REDUCE_RHO properly defined, we can also set IMPROVE_GEO as follows. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= eta1 .or. knew_tr == 0) + ! !improve_geo = bad_trstep .and. (.not. reduce_rho) .and. (.not. close_itpset) + + ! With IMPROVE_GEO properly defined, we can also set REDUCE_RHO as follows. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) + ! !reduce_rho = bad_trstep .and. (.not. improve_geo) .and. small_trrad + + ! BOBYQA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. + !call assert(.not. (improve_geo .and. reduce_rho), 'IMPROVE_GEO and REDUCE_RHO are not both TRUE', srname) + ! + ! If SHORTD or TRFAIL is TRUE, then either IMPROVE_GEO or REDUCE_RHO is TRUE unless CLOSE_ITPSET + ! is TRUE but SMALL_TRRAD is FALSE. + !call assert((.not. (shortd .or. trfail)) .or. (improve_geo .or. reduce_rho .or. & + ! & (close_itpset .and. .not. small_trrad)), 'If SHORTD or TRFAIL is TRUE, then either & + ! & IMPROVE_GEO or REDUCE_RHO is TRUE unless CLOSE_ITPSET is TRUE but SMALL_TRRAD is FALSE', srname) + !----------------------------------------------------------------------------------------------! + + + ! Since IMPROVE_GEO and REDUCE_RHO are never TRUE simultaneously, the following two blocks are + ! exchangeable: IF (IMPROVE_GEO) ... END IF and IF (REDUCE_RHO) ... END IF. + + ! Improve the geometry of the interpolation set by removing a point and adding a new one. + if (improve_geo) then + ! XPT(:, KNEW_GEO) will become XOPT + D below. KNEW_GEO /= KOPT unless there is a bug. + knew_geo = int(maxloc(distsq, dim=1), kind(knew_geo)) + + ! Set DELBAR, which will be used as the trust-region radius for the geometry-improving + ! scheme GEOSTEP. Note that DELTA has been updated before arriving here. + delbar = max(min(TENTH * sqrt(maxval(distsq)), delta), rho) ! Powell's code + !delbar = rho ! Powell's UOBYQA code + !delbar = max(min(TENTH * sqrt(maxval(distsq)), HALF * delta), rho) ! Powell's NEWUOA code + !delbar = max(TENTH * delta, rho) ! Powell's LINCOA code + + ! Find D so that the geometry of XPT will be improved when XPT(:, KNEW_GEO) becomes XOPT + D. + d = geostep(knew_geo, kopt, bmat, delbar, sl, su, xpt, zmat) + + ! Call RESCUE if rounding errors have damaged the denominator corresponding to D. + ! 1. This does make a difference, yet RESCUE seems not invoked often after a geometry step. + ! 2. In Powell's implementation, it may happen that RESCUE only recalculates [BMAT, ZMAT] + ! without introducing any new point into XPT. In that case, GEOSTEP will have to be called + ! after RESCUE, without which the code may encounter an infinite cycling. We have modified + ! RESCUE so that it introduces at least one new point into XPT and there is no need to call + ! GEOSTEP afterward. This improves the performance a bit and simplifies the flow of the code. + ! 3. It is tempting to incorporate XOPT+D into the interpolation even if RESCUE is called. + ! However, this cannot be done without recalculating KNEW_GEO, as XPT has been changed by + ! RESCUE, so that it is invalid to replace XPT(:, KNEW_GEO) with XOPT+D anymore. With a new + ! KNEW_GEO, the step D will become improper as it was chosen according to the old KNEW_GEO. + vlag = calvlag(kopt, bmat, d, xpt, zmat) + den = calden(kopt, bmat, d, xpt, zmat) + to_rescue = (.not. (is_finite(sum(abs(vlag))) .and. den(knew_geo) > HALF * vlag(knew_geo)**2)) + if (to_rescue) then + if (rescued) then + info = DAMAGING_ROUNDING ! The last RESCUE did not improve the situation. + exit + end if + call rescue(calfun, solver, iprint, maxfun, delta, ftarget, xl, xu, kopt, nf, fhist, & + & fval, gopt, hq, pq, sl, su, xbase, xhist, xpt, bmat, zmat, subinfo) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + rescued = .true. + dnorm_rec = REALMAX + moderr_rec = REALMAX + else + ! Calculate the next value of the objective function. + x = xinbd(xbase, xpt(:, kopt) + d, xl, xu, sl, su) ! X = XBASE + XOPT + D without rounding. + call evaluate(calfun, x, f) + nf = nf + 1_IK + rescued = .false. ! Set RESCUED to FALSE after evaluating F at a new point. + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Geometry', iprint, nf, delbar, f, x) + ! Save X, F into the history. + call savehist(nf, x, xhist, f, fhist) + + ! Check whether to exit + subinfo = checkexit(maxfun, nf, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + + ! Update DNORM_REC and MODERR_REC. + ! DNORM_REC records the DNORM of the recent function evaluations with the current RHO. + ! Powell's code does not update DNORM. Therefore, DNORM is the length of the last + ! trust-region trial step, inconsistent with MODERR_REC. The same problem exists in NEWUOA. + dnorm = min(delbar, norm(d)) + dnorm_rec = [dnorm_rec(2:size(dnorm_rec)), dnorm] + ! MODERR is the error of the current model in predicting the change in F due to D. + ! MODERR_REC records the prediction errors of the recent models with the current RHO. + moderr = f - fval(kopt) - quadinc(d, xpt, gopt, pq, hq) ! QRED = Q(XOPT) - Q(XOPT + D) + moderr_rec = [moderr_rec(2:size(moderr_rec)), moderr] + + ! Is the newly generated X better than current best point? + ximproved = (f < fval(kopt)) + + ! Update [BMAT, ZMAT] (represents H in the BOBYQA paper), [FVAL, XPT, KOPT, FOPT, XOPT], + ! and [GQ, HQ, PQ] (the quadratic model), so that XPT(:, KNEW_GEO) becomes XOPT + D. + xdrop = xpt(:, knew_geo) + xosav = xpt(:, kopt) + call updateh(knew_geo, kopt, d, xpt, bmat, zmat) + call updatexf(knew_geo, ximproved, f, max(sl, min(su, xosav + d)), kopt, fval, xpt) + call updateq(knew_geo, ximproved, bmat, d, moderr, xdrop, xosav, xpt, zmat, gopt, hq, pq) + if (.not. (all(is_finite(gopt)) .and. all(is_finite(hq)) .and. all(is_finite(pq)))) then + info = NAN_INF_MODEL + exit + end if + end if + end if ! End of IF (IMPROVE_GEO). The procedure of improving geometry ends. + + ! The calculations with the current RHO are complete. Enhance the resolution of the algorithm + ! by reducing RHO; update DELTA at the same time. + if (reduce_rho) then + if (rho <= rhoend) then + info = SMALL_TR_RADIUS + exit + end if + delta = max(HALF * rho, redrho(rho, rhoend)) + rho = redrho(rho, rhoend) + ! Print a message about the reduction of RHO according to IPRINT. + call rhomsg(solver, iprint, nf, delta, fval(kopt), rho, xbase + xpt(:, kopt)) + ! DNORM_REC and MODERR_REC are corresponding to the recent function evaluations with + ! the current RHO. Update them after reducing RHO. + dnorm_rec = REALMAX + moderr_rec = REALMAX + end if ! End of IF (REDUCE_RHO). The procedure of reducing RHO ends. + + ! Shift XBASE if XOPT may be too far from XBASE. + ! Powell's original criteria for shifting XBASE is as follows. + ! 1. After a trust region step that is not short, shift XBASE if SUM(XOPT**2) >= 1.0E3*DNORM**2. + ! In this case, it seems quite important for the performance to recalculate QRED. + ! 2. Before a geometry step, shift XBASE if SUM(XOPT**2) >= 1.0E3*DELBAR**2. + if (sum(xpt(:, kopt)**2) >= 1.0E3_RP * delta**2) then + ! Other possible criteria: SUM(XOPT**2) >= 1.0E4*DELTA**2, SUM(XOPT**2) >= 1.0E4*RHO**2. + sl = min(sl - xpt(:, kopt), ZERO) + su = max(su - xpt(:, kopt), ZERO) + call shiftbase(kopt, xbase, xpt, zmat, bmat, pq, hq) + xbase = max(xl, min(xu, xbase)) + end if + + ! Report the current best value, and check if user asks for early termination. + if (present(callback_fcn)) then + call callback_fcn(xbase + xpt(:, kopt), fval(kopt), nf, tr, terminate=terminate) + if (terminate) then + info = CALLBACK_TERMINATE + exit + end if + end if + +end do ! End of DO TR = 1, MAXTR. The iterative procedure ends. + +! Return from the calculation, after trying the Newton-Raphson step if it has not been tried yet. +if (info == SMALL_TR_RADIUS .and. shortd .and. dnorm > TENTH * rhoend .and. nf < maxfun) then + x = xinbd(xbase, xpt(:, kopt) + d, xl, xu, sl, su) ! In precise arithmetic, X = XBASE + XOPT + D. + call evaluate(calfun, x, f) + nf = nf + 1_IK + ! Print a message about the function evaluation according to IPRINT. + ! Zaikun 20230512: DELTA has been updated. RHO is only indicative here. TO BE IMPROVED. + call fmsg(solver, 'Trust region', iprint, nf, rho, f, x) + ! Save X, F into the history. + call savehist(nf, x, xhist, f, fhist) +end if + +! Choose the [X, F] to return: either the current [X, F] or [XBASE + XOPT, FOPT]. +if (fval(kopt) < f .or. is_nan(f)) then + x = xinbd(xbase, xpt(:, kopt), xl, xu, sl, su) ! In precise arithmetic, X = XBASE + XOPT. + f = fval(kopt) +end if + +! Arrange FHIST and XHIST so that they are in the chronological order. +call rangehist(nf, xhist, fhist) + +! Print a return message according to IPRINT. +call retmsg(solver, info, iprint, nf, f, x) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(all(x >= xl) .and. all(x <= xu), 'XL <= X <= XU', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + do k = 1, min(nf, maxxhist) + call assert(all(xhist(:, k) >= xl) .and. all(xhist(:, k) <= xu), 'XL <= XHIST <= XU', srname) + end do + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(fhist(1:min(nf, maxfhist)) < f), 'F is the smallest in FHIST', srname) +end if + +end subroutine bobyqb + + +function errbd(crvmin, d, gopt, hq, moderr_rec, pq, rho, sl, su, xopt, xpt) result(ebound) +!--------------------------------------------------------------------------------------------------! +! This function defines EBOUND, which will be used as a bound to test whether the errors in recent +! models are sufficiently small. See the elaboration on pages 30--31 of the BOBYQA paper, in the +! paragraphs surrounding (6.8)--(6.11). +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : matprod, diag, issymmetric, trueloc +use, non_intrinsic :: powalg_mod, only : hess_mul + +implicit none + +! Inputs +real(RP), intent(in) :: crvmin +real(RP), intent(in) :: d(:) +real(RP), intent(in) :: gopt(:) +real(RP), intent(in) :: hq(:, :) +real(RP), intent(in) :: moderr_rec(:) +real(RP), intent(in) :: pq(:) +real(RP), intent(in) :: rho +real(RP), intent(in) :: sl(:) +real(RP), intent(in) :: su(:) +real(RP), intent(in) :: xopt(:) +real(RP), intent(in) :: xpt(:, :) + +! Outputs +real(RP) :: ebound + +! Local variables +character(len=*), parameter :: srname = 'ERRBD' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: bfirst(size(d)) +real(RP) :: bsecond(size(d)) +real(RP) :: gnew(size(d)) +real(RP) :: xnew(size(d)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(crvmin >= 0, 'CRVMIN >= 0', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(size(gopt) == n, 'SIZE(GOPT) == N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is n-by-n and symmetric', srname) + call assert(size(pq) == npt, 'SIZE(PQ) == NPT', srname) + call assert(rho > 0, 'RHO > 0', srname) + call assert(size(sl) == n .and. size(su) == n, 'SIZE(SL) == N == SIZE(SU)', srname) + call assert(size(xopt) == n .and. all(is_finite(xopt)), 'SIZE(XOPT) == N, XOPT is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(all(xopt >= sl .and. xopt <= su), 'SL <= XOPT <= SU', srname) + call assert(all(xpt >= spread(sl, dim=2, ncopies=npt) .and. & + & xpt <= spread(su, dim=2, ncopies=npt)), 'SL <= XPT <= SU', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +xnew = xopt + d +gnew = gopt + hess_mul(d, xpt, pq, hq) +bfirst = maxval(abs(moderr_rec)) +bfirst(trueloc(xnew <= sl)) = gnew(trueloc(xnew <= sl)) * rho +bfirst(trueloc(xnew >= su)) = -gnew(trueloc(xnew >= su)) * rho +bsecond = HALF * (diag(hq) + matprod(xpt**2, pq)) * rho**2 +ebound = minval(max(bfirst, bfirst + bsecond)) +if (crvmin > 0) then + ebound = min(ebound, 0.125_RP * crvmin * rho**2) +end if + +!====================! +! Calculation ends ! +!====================! + +end function errbd + + +end module bobyqb_mod diff --git a/examples/fortran/prima/native/bobyqa/geometry.f90 b/examples/fortran/prima/native/bobyqa/geometry.f90 new file mode 100644 index 000000000..863d7a16f --- /dev/null +++ b/examples/fortran/prima/native/bobyqa/geometry.f90 @@ -0,0 +1,618 @@ +module geometry_bobyqa_mod +!--------------------------------------------------------------------------------------------------! +! This module contains subroutines concerning the geometry-improving of the interpolation set XPT. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the BOBYQA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Tue 10 Feb 2026 02:07:34 PM CET +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: setdrop_tr, geostep + + +contains + + +function setdrop_tr(kopt, ximproved, bmat, d, delta, rho, xpt, zmat) result(knew) +!--------------------------------------------------------------------------------------------------! +! This subroutine sets KNEW to the index of the interpolation point to be deleted AFTER A TRUST +! REGION STEP. KNEW will be set in a way ensuring that the geometry of XPT is "optimal" after +! XPT(:, KNEW) is replaced with XNEW = XOPT + D, where D is the trust-region step. See discussions +! around (6.1) of the BOBYQA paper. +! N.B.: +! 1. If XIMPROVED = TRUE, then KNEW > 0 so that XNEW is included into XPT. Otherwise, it is a bug. +! 2. If XIMPROVED = FALSE, then KNEW /= KOPT so that XPT(:, KOPT) stays. Otherwise, it is a bug. +! 3. It is tempting to take the function value into consideration when defining KNEW, for example, +! set KNEW so that FVAL(KNEW) = MAX(FVAL) as long as F(XNEW) < MAX(FVAL), unless there is a better +! choice. However, this is not a good idea, because the definition of KNEW should benefit the +! quality of the model that interpolates f at XPT. A set of points with low function values is not +! necessarily a good interpolation set. In contrast, a good interpolation set needs to include +! points with relatively high function values; otherwise, the interpolant will unlikely reflect the +! landscape of the function sufficiently. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : issymmetric, trueloc +use, non_intrinsic :: powalg_mod, only : calden + +implicit none + +! Inputs +integer(IK), intent(in) :: kopt +logical, intent(in) :: ximproved +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: delta +real(RP), intent(in) :: rho +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Outputs +integer(IK) :: knew + +! Local variables +character(len=*), parameter :: srname = 'SETDROP_TR' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: den(size(xpt, 2)) +real(RP) :: distsq(size(xpt, 2)) +real(RP) :: score(size(xpt, 2)) +real(RP) :: weight(size(xpt, 2)) + +! Sizes +n = int(size(xpt, 1), kind(npt)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(delta >= rho .and. rho > 0, 'DELTA >= RHO > 0', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Calculate the distance squares between the interpolation points and the "optimal point". When +! identifying the optimal point, it is reasonable to take into account the new trust-region trial +! point XPT(:, KOPT) + D, which will become the optimal point in the next iteration if XIMPROVED +! is TRUE. Powell suggested this in +! - (56) of the UOBYQA paper, lines 276--297 of uobyqb.f, +! - (7.5) and Box 5 of the NEWUOA paper, lines 383--409 of newuob.f, +! - the last paragraph of page 26 of the BOBYQA paper, lines 435--465 of bobyqb.f. +! However, Powell's LINCOA code is different. In his code, the KNEW after a trust-region step is +! picked in lines 72--96 of the update.f for LINCOA, where DISTSQ is calculated as the square of the +! distance to XPT(KOPT, :) (Powell recorded the interpolation points in rows). However, note that +! the trust-region trial point has not been included into XPT yet --- it cannot be included without +! knowing KNEW (see lines 332-344 and 404--431 of lincob.f). Hence Powell's LINCOA code picks KNEW +! based on the distance to the un-updated "optimal point", which is unreasonable. This has been +! corrected in our implementation of LINCOA, yet it does not boost the performance. +if (ximproved) then + distsq = sum((xpt - spread(xpt(:, kopt) + d, dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - (xpt(:, kopt) + d)).^2) % d should be a column! Implicit expansion +else + distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - xpt(:, kopt)).^2) % Implicit expansion +end if + +weight = max(ONE, distsq / rho**2)**4 +! Other possible definitions of WEIGHT. +! !weight = max(ONE, distsq / rho**2)**3.5 ! Quite similar to power 4 +! !weight = max(ONE, distsq / rho**2)**3 ! Not bad +! !weight = max(ONE, distsq / delta**2)**2 ! Powell's code. Does not works as well as the above. +! !weight = max(ONE, distsq / rho**2)**2 ! Similar to Powell's code, not better. +! !weight = max(ONE, distsq / delta**2) ! Defined in (6.1) of the BOBYQA paper. It works poorly! +! !weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**3.5 ! The same as DISTSQ/RHO**2. +! The following WEIGHT all perform a bit worse than the above one. +! !weight = max(ONE, distsq / delta**2)**3.5 +! !weight = max(ONE, distsq / delta**2)**2.5 +! !weight = max(ONE, distsq / delta**2)**3 +! !weight = max(ONE, distsq / delta**2)**4 +! !weight = max(ONE, distsq / delta**2)**4.5 +! !weight = max(ONE, distsq / rho**2)**2.5 +! !weight = max(ONE, distsq / rho**2)**3 +! !weight = max(ONE, distsq / rho**2)**4.5 + +! Different from NEWUOA/LINCOA, the possibility that entries in DEN become negative is handled by +! RESCUE. Hence the SCORE here uses DEN in contrast to ABS(DEN) in NEWUOA/LINCOA. +den = calden(kopt, bmat, d, xpt, zmat) +score = weight * den + +! If the new F is not better than FVAL(KOPT), we set SCORE(KOPT) = -1 to avoid KNEW = KOPT. +if (.not. ximproved) then + score(kopt) = -ONE +end if + +! SCORE(K) = NaN implies DEN(K) = NaN. We exclude such K as we want DEN to be big. +score(trueloc(is_nan(score))) = -ONE + +knew = 0 +! The following IF works slightly better than `IF (ANY(SCORE > 0))` from Powell's BOBYQA/LINCOA code. +if (any(score > 1) .or. (ximproved .and. any(score > 0))) then ! Powell's UOBYQA and NEWUOA code. + ! See (6.1) of the BOBYQA paper for the definition of KNEW in this case. + knew = int(maxloc(score, dim=1), kind(knew)) + !!MATLAB: [~, knew] = max(score); +end if + +! Powell's code does not include the following instructions. With Powell's code, if DEN consists of +! only NaN, then KNEW can be 0 even when XIMPROVED is TRUE. Here, we set KNEW to the following value, +! to make sure that the new trial point is included in the interpolation set. However, the updating +! subroutine will likely need to skip the update of the Lagrange polynomials (i.e., H), or they +! would be destroyed by the NaNs. +if ((ximproved .and. knew == 0) .or. knew < 0) then ! KNEW < 0 is impossible in theory. + knew = int(maxloc(distsq, dim=1), kind(knew)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(knew /= kopt .or. ximproved, 'KNEW /= KOPT unless XIMPROVED = TRUE', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless XIMPROVED = FALSE', srname) + ! KNEW >= 1 when XIMPROVED = TRUE unless NaN occurs in DISTSQ, which should not happen if the + ! starting point does not contain NaN and the trust-region/geometry steps never contain NaN. +end if + +end function setdrop_tr + + +function geostep(knew, kopt, bmat, delbar, sl, su, xpt, zmat) result(d) +!--------------------------------------------------------------------------------------------------! +! This subroutine finds a step D that intends to improve the geometry of the interpolation set +! when XPT(:, KNEW) is changed to XOPT + D, where XOPT = XPT(:, KOPT). See Section 3 of the BOBYQA +! paper, particularly the discussions starting from (3.7). +! +! The arguments XPT, BMAT, ZMAT, SL and SU all have the same meanings as in BOBYQB. +! KOPT is the index of the optimal interpolation point. +! KNEW is the index of the interpolation point that is going to be moved. +! DELBAR is the trust region bound for the geometry step. +! XLINE will be a suitable new position for the interpolation point XPT(:, KNEW). Specifically, it +! satisfies the SL, SU and trust region bounds and it should provide a large denominator in the +! next call of UPDATE. The step XLINE-XOPT from XOPT is restricted to moves along the straight +! lines through XOPT and another interpolation point. +! XCAUCHY provides a large value of the modulus of the KNEW-th Lagrange function subject to the +! constraints that have been mentioned, its main difference from XLINE being that XCAUCHY-XOPT +! is a bound-constrained version of the Cauchy step within the trust region. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, TEN, EPS, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : matprod, inprod, trueloc, norm, issymmetric +use, non_intrinsic :: powalg_mod, only : hess_mul, calden + +implicit none + +! Inputs +integer(IK), intent(in) :: knew +integer(IK), intent(in) :: kopt +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: delbar +real(RP), intent(in) :: sl(:) ! SL(N) +real(RP), intent(in) :: su(:) ! SU(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT-N-1) + +! Outputs +real(RP) :: d(size(xpt, 1)) ! D(N) + +! Local variables +character(len=*), parameter :: srname = 'GEOSTEP' +integer(IK) :: ibd +integer(IK) :: ilbd +integer(IK) :: isbd(3, size(xpt, 2)) +integer(IK) :: isq +integer(IK) :: iubd +integer(IK) :: k +integer(IK) :: ksq +integer(IK) :: ksqs(3) +integer(IK) :: n +integer(IK) :: npt +integer(IK) :: uphill +logical :: mask_fixl(size(xpt, 1)) +logical :: mask_fixu(size(xpt, 1)) +logical :: mask_free(size(xpt, 1)) +real(RP) :: alpha, stpsiz +real(RP) :: betabd(3, size(xpt, 2)) +real(RP) :: bigstp +real(RP) :: curv +real(RP) :: dderiv(size(xpt, 2)) +real(RP) :: den_cauchy(size(xpt, 2)) +real(RP) :: den_line(size(xpt, 2)) +real(RP) :: distsq(size(xpt, 2)) +real(RP) :: ggfree +real(RP) :: glag(size(xpt, 1)) +real(RP) :: grdstp +real(RP) :: gs +real(RP) :: lfrac(size(xpt, 1)) +real(RP) :: pqlag(size(xpt, 2)) +real(RP) :: predsq(3, size(xpt, 2)) +real(RP) :: resis +real(RP) :: s(size(xpt, 1)) +real(RP) :: scaling +real(RP) :: sfixsq +real(RP) :: slbd +real(RP) :: slbd_test(size(xpt, 1)) +real(RP) :: ssqsav +real(RP) :: stplen(3, size(xpt, 2)) +real(RP) :: stpm +real(RP) :: subd +real(RP) :: subd_test(size(xpt, 1)) +real(RP) :: sumin +real(RP) :: sxpt(size(xpt, 2)) +real(RP) :: ufrac(size(xpt, 1)) +real(RP) :: vlag(3, size(xpt, 2)) +real(RP) :: vlagsq +real(RP) :: vlagsq_cauchy +real(RP) :: x(size(xpt, 1)) +real(RP) :: xcauchy(size(xpt, 1)) +real(RP) :: xdiff(size(xpt, 1)) +real(RP) :: xline(size(xpt, 1)) +real(RP) :: xopt(size(xpt, 1)) +real(RP) :: xtemp(size(xpt, 1)) + +! Sizes. +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(knew >= 1 .and. knew <= npt, '1 <= KNEW <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew /= kopt, 'KNEW /= KOPT', srname) + call assert(delbar > 0, 'DELBAR > 0', srname) + call assert(size(sl) == n .and. all(sl <= 0), 'SIZE(SL) == N, SL <= 0', srname) + call assert(size(su) == n .and. all(su >= 0), 'SIZE(SU) == N, SU >= 0', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(all(xpt >= spread(sl, dim=2, ncopies=npt)) .and. & + & all(xpt <= spread(su, dim=2, ncopies=npt)), 'SL <= XPT <= SU', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT) == [N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1_IK, 'SIZE(ZMAT) == [NPT, NPT-N-1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! PQLAG contains the leading NPT elements of the KNEW-th column of H, and it provides the second +! derivative parameters of LFUNC, which is the KNEW-th Lagrange function. ALPHA will is the KNEW-th +! diagonal element of the H matrix. +pqlag = matprod(zmat, zmat(knew, :)) +alpha = pqlag(knew) + +! Read XOPT. +xopt = xpt(:, kopt) + +! Calculate the gradient GLAG of the KNEW-th Lagrange function at XOPT. +glag = bmat(:, knew) + hess_mul(xopt, xpt, pqlag) + +! In case GLAG contains NaN, set D to a displacement from XOPT to XPT(:, KNEW) and return. Powell's +! code does not have this, and D may be NaN in the end. Note that it is crucial to ensure that a +! geometry step is nonzero. +if (.not. is_finite(sum(abs(glag)))) then + d = xpt(:, knew) - xopt + d = min(HALF, delbar / norm(d)) * d ! Since XPT respects the bounds, so does XOPT + D. + return +end if + +! Search for a large denominator along the straight lines through XOPT and another interpolation +! point, subject to the bound constraints and the trust region. According to these constraints, SLBD +! and SUBD will be lower and upper bounds on the step along each of these lines in turn. On each +! line, we will evaluate the value of the KNEW-th Lagrange function at 3 trial points, and estimate +! the denominator accordingly. The three points take the form (1-t)*XOPT + t*XPT(:, K) with step +! lengths t = SLBD, SUBD, and STPM, corresponding to the upper (U) bound of t, the lower (L) bound +! of t, and a medium (M) step. In total, 3*(NPT-1) trial points will be considered. On the K-th line, +! we intend to maximize the modulus of PHI_K(t) = LFUNC((1-t)*XOPT + t*XPT(:,K)); overall, we intend +! to find a trial point rendering a large value of the PREDSQ defined in (3.11) of the BOBYQA paper. +! +! We start with the following DO loop, the purpose of which is to define two 3-by-NPT arrays STPLEN +! and ISBD. For each K, STPLEN(1:3, K) and ISBD(1:3, K) corresponds to the straight line through +! XOPT and XPT(:, K). STPLEN(1:3, K) contains SLBD, SUBD, and STPM in this order, which are the step +! lengths for the three trial points on this line. The three entries of SBDI(1:3, K) indicate +! whether the corresponding trial points lie on bounds; SBDI(I, K) = J > 0 means that the I-th trail +! point on the K-th line attains the J-th upper bound, SBDI(I, K) = -J < 0 indicates reaching the +! J-th lower bound, and SBDI(I, K) = 0 means not touching any bound. +dderiv = matprod(glag, xpt) - inprod(glag, xopt) ! The derivatives PHI_K'(0). +distsq = sum((xpt - spread(xopt, dim=2, ncopies=npt))**2, dim=1) +do k = 1, npt + ! It does not make sense to consider "straight line through XOPT and XPT(:, KOPT)". Hence set + ! STPLEN(:, KOPT) = 0 and ISBD(:, KOPT) = 0 so that VLAG(:, K) and PREDSQ(:, K) obtained after + ! this loop will be both zero and the search will skip K = KOPT. To avoid undesired/unpredictable + ! behavior due to possible NaN, set DDERIV(K) = 0 if K = KOPT or if DDERIV(K) is originally NaN. + if (k == kopt .or. is_nan(dderiv(k))) then + dderiv(k) = ZERO + stplen(:, k) = ZERO + isbd(:, k) = 0 + cycle + end if + + subd = delbar / sqrt(distsq(k)) ! DISTSQ(K) > 0 unless K == KOPT or the input is incorrect. + slbd = -subd + ilbd = 0 + iubd = 0 + sumin = min(ONE, subd) + + ! Revise SLBD and SUBD if necessary because of the bounds in SL and SU according to LFRAC, UFRAC. + ! N.B.: We calculate LFRAC only at the positions where SL - XOPT > -ABS(XDIFF) * SUBD, because + ! the values of LFRAC are relevant only at the positions where ABS(LFRAC) < SUBD. Powell's code + ! does not check this inequality before evaluating LFRAC, and overflow may occur due to large + ! entries of SL. Note that SL - XOPT > -ABS(XDIFF) * SUBD implies that XDIFF /= 0, as long as + ! SL <= XOPT is ensured. In addition, when initializing LFRAC to SIGN(SUBD, -XDIFF), we do not + ! need to worry about the case where XDIFF = 0, because we only use LFRAC when XDIFF /= 0. + ! Similar things can be said about UFRAC. + xdiff = xpt(:, k) - xopt + lfrac = sign(subd, -xdiff) + where (sl - xopt > -abs(xdiff) * subd) lfrac = (sl - xopt) / xdiff + ufrac = sign(subd, xdiff) + where (su - xopt < abs(xdiff) * subd) ufrac = (su - xopt) / xdiff + !!MATLAB code for LFRAC and UFRAC (the code is simpler as we are not concerned about overflow): + !!xdiff = xpt(:, k) - xopt; + !!lfrac = (sl - xopt) / xdiff; + !!ufrac = (su - xopt) / xdiff; + + ! First, revise SLBD. Note that SLBD_TEST <= 0 unless the input violates XOPT >= SL. + slbd_test = slbd + slbd_test(trueloc(xdiff > 0)) = lfrac(trueloc(xdiff > 0)) + slbd_test(trueloc(xdiff < 0)) = ufrac(trueloc(xdiff < 0)) + if (any(slbd_test > slbd)) then + ilbd = int(maxloc(slbd_test, mask=(.not. is_nan(slbd_test)), dim=1), kind(ilbd)) + slbd = slbd_test(ilbd) + ilbd = -ilbd * nint(sign(ONE, xdiff(ilbd)), kind(ilbd)) + !!MATLAB: + !![slbd, ilbd] = max(slbd_test, [], 'omitnan'); + !!ilbd = -ilbd * sign(xdiff(ilbd)); + end if + + ! Second, revise SUBD. Note that SUBD_TEST >= 0 unless the input violates XOPT <= SU. + subd_test = subd + subd_test(trueloc(xdiff > 0)) = ufrac(trueloc(xdiff > 0)) + subd_test(trueloc(xdiff < 0)) = lfrac(trueloc(xdiff < 0)) + if (any(subd_test < subd)) then + iubd = int(minloc(subd_test, mask=(.not. is_nan(subd_test)), dim=1), kind(iubd)) + subd = max(sumin, subd_test(iubd)) + iubd = iubd * nint(sign(ONE, xdiff(iubd)), kind(iubd)) + !!MATLAB: + !![subd, iubd] = min(subd_test, [], 'omitnan'); + !!subd = max(sumin, subd); + !!iubd = iubd * sign(xdiff(iubd)); + end if + + if (DEBUGGING) then + call assert(slbd <= 0 .and. subd >= 0, 'SLBD <= 0 <= SUBD', srname) + end if + + ! Now, define the step length STPM between SLBD and SUBD by finding the critical point of the + ! function PHI_K(t) = LFUNC((1-t)*XOPT + t*XPT(:,K)) mentioned above. It is a quadratic since + ! LFUNC is the KNEW-th Lagrange function. For K /= KNEW, the critical point is 0.5, as + ! PHI_K(0) = 1 = PHI_K(1); when K = KNEW, it is -0.5*PHI_K'(0) / (1 - PHI_K'(0)), because + ! PHI_K(0) = 0 and PHI_K(1) = 1. + stpm = HALF + if (k == knew) then + stpm = slbd + if (abs(ONE - dderiv(k)) > 0) then + stpm = -HALF * dderiv(k) / (ONE - dderiv(k)) + end if + end if + stpm = max(slbd, min(subd, stpm)) + + stplen(:, k) = [slbd, subd, stpm] + isbd(:, k) = [ilbd, iubd, 0_IK] +end do + +! The following lines calculate PREDSQ for all the 3*(NPT-1) trial points. +! First, compute VLAG = PHI(STPLEN). Using the fact that PHI_K(0) = 0, PHI_K(1) = delta_{K, KNEW} +! (Kronecker delta), and recalling the PHI_K is quadratic, we can find that +! PHI_K(t) = t*(1-t)*PHI_K'(0) for K /= KNEW, and PHI_KNEW = t*[t*(1-PHI_K'(0)) + PHI_K'(0)]. +vlag = stplen * (ONE - stplen) * spread(dderiv, dim=1, ncopies=3) +!!MATLAB: vlag = stplen .* (1 - stplen) .* dderiv; % Implicit expansion; dderiv is a row! +vlag(:, knew) = stplen(:, knew) * (stplen(:, knew) * (ONE - dderiv(knew)) + dderiv(knew)) +! Set NaNs in VLAG to 0 so that the behavior of MAXVAL(ABS(VLAG)) is predictable. VLAG does not have +! NaN unless XPT does, which would be a bug. MAXVAL(ABS(VLAG)) appears in Powell's code, not here. +where (is_nan(vlag)) vlag = ZERO !!MATLAB: vlag(isnan(vlag)) = 0; +! +! Second, BETABD is the upper bound of BETA given in (3.10) of the BOBYQA paper. +betabd = HALF * (stplen * (ONE - stplen) * spread(distsq, dim=1, ncopies=3))**2 +!!MATLAB: betabd = 0.5 * (stplen .* (1-stplen) .* distsq).^2 % Implicit expansion; distsq is a row! +! +! Finally, PREDSQ is the quantity defined in (3.11) of the BOBYQA paper. +predsq = vlag * vlag * (vlag * vlag + alpha * betabd) +! Set NaNs in PREDSQ to 0 so that the behavior of MAXLOC(PREDSQ) is predictable. PREDSQ does not +! have NaN unless XPT does, which would be a bug. +where (is_nan(predsq)) predsq = ZERO !!MATLAB: predsq(isnan(predsq)) = 0 + +! Locate the trial point the renders the maximum of PREDSQ. It is the ISQ-th trial point on the +! straight line through XOPT and XPT(:, KSQ). +! N.B.: 1. The strategy is a bit different from Powell's original code. In Powell's code and the +! BOBYQA paper, we first select the trial point that gives the largest value of ABS(VLAG) on each +! straight line, and then maximize PREDSQ among the (NPT-1) selected points. Here we maximize PREDSQ +! among all the trial points. It works slightly better than Powell's version in a test on 20220428. +! Powell's version is as follows. +!---------------------------------------------------------------------! +!isqs = int(maxloc(abs(vlag), dim=1), kind(isqs)) ! SIZE(ISQS) = NPT +!ksq = int(maxloc([(predsq(isqs(k), k), k=1, npt)], dim=1), kind(ksq)) +!isq = isqs(ksq) +!---------------------------------------------------------------------! +! 2. Recall that we have set the NaN entries of PREDSQ to zero, if there is any. Thus the KSQS below +! is a well defined integer array, all the three entries lying between 1 and NPT. +ksqs = int(maxloc(predsq, dim=2), kind(ksqs)) +isq = int(maxloc([predsq(1, ksqs(1)), predsq(2, ksqs(2)), predsq(3, ksqs(3))], dim=1), kind(isq)) +ksq = ksqs(isq) +!!MATLAB: +!![~, ksqs] = max(predsq, [], 'omitnan'); +!![~, isq] = max([predsq(1, ksqs(1)), predsq(2, ksqs(2)), predsq(3, ksqs(3))]); +!!ksq = ksqs(isq); + +! Construct XLINE in a way that satisfies the bound constraints exactly. +stpsiz = stplen(isq, ksq) +ibd = isbd(isq, ksq) + +xline = max(sl, min(su, xopt + stpsiz * (xpt(:, ksq) - xopt))) +if (ibd < 0) then + xline(-ibd) = sl(-ibd) +end if +if (ibd > 0) then + xline(ibd) = su(ibd) +end if + +! Calculate DENOM for the current choice of D. Indeed, only DEN_LINE(KNEW) is needed. +! Zaikun 20250907: It was observed numerically that D could be ZERO here (i.e., XLINE = XOPT). +! Should this be impossible in theory? +d = xline - xopt +den_line = calden(kopt, bmat, d, xpt, zmat) + +!--------------------------------------------------------------------------------------------------! +! The following IF ... END IF does not exist in Powell's code. SURPRISINGLY, the performance of +! BOBYQA on bound constrained problems (but NOT unconstrained ones) is evidently improved by this IF +! ... END IF, which means to try the Cauchy step only in the late stage of the algorithm, e.g., when +! DELBAR is relatively small. WHY? In the following condition, 1.0E-2 works well if we use +! DEN_CAUCHY to decide whether to take the Cauchy step; 1.0E-3 works well if we use VLAGSQ instead. +! How to make this condition adaptive? A naive idea is to replace the thresholds to, +! e.g.,1.0E-2*RHOBEG. However, in a test on 20220517, this adaptation worsened the performance. In +! such a test, RHOBEG must take a value that is quite different from one. We tried RHOBEG = 0.9E-2. +!if (delbar > 1.0E-3) then +!if (delbar > 1.0E-1) then +if (delbar > 1.0E-2) then + return +end if +!--------------------------------------------------------------------------------------------------! + +! Prepare for the method that assembles the constrained Cauchy step in S. The sum of squares of the +! fixed components of S is formed in SFIXSQ, and the free components of S are set to BIGSTP. When +! UPHILL = 0, the method calculates the downhill version of XCAUCHY, which intends to minimize the +! KNEW-th Lagrange function; when UPHILL = 1, it calculates the uphill version that intends to +! maximize the Lagrange function. +bigstp = delbar + delbar ! N.B.: In the sequel, S <= BIGSTP. +xcauchy = xopt +vlagsq_cauchy = ZERO +do uphill = 0, 1 + if (uphill == 1) then + glag = -glag + end if + s = ZERO + mask_free = (min(xopt - sl, glag) > 0 .or. max(xopt - su, glag) < 0) + s(trueloc(mask_free)) = bigstp + ggfree = sum(glag(trueloc(mask_free))**2) + ! In Powell's code, the subroutine returns immediately if GGFREE is 0. However, GGFREE depends + ! on GLAG, which in turn depends on UPHILL. It can happen that GGFREE is 0 when UPHILL = 0 but + ! not so when UPHILL= 1. Thus we skip the iteration for the current UPHILL but do not return. + if (ggfree <= 0 .or. is_nan(ggfree)) then + cycle + end if + + ! Investigate whether more components of S can be fixed. Note that the loop counter K does not + ! appear in the loop body. The purpose of K is only to impose an explicit bound on the number of + ! loops. Powell's code does not have such a bound. The bound is not a true restriction, because + ! we can check that (SFIXSQ > SSQSAV .AND. GGFREE > 0) must fail within N loops. + sfixsq = ZERO + grdstp = ZERO + do k = 1, n + resis = delbar**2 - sfixsq + if (resis <= 0) then + exit + end if + ssqsav = sfixsq + grdstp = sqrt(resis / ggfree) + xtemp = xopt - grdstp * glag + mask_fixl = (s >= bigstp .and. xtemp <= sl) ! S == BIGSTP & XTEMP == SL + mask_fixu = (s >= bigstp .and. xtemp >= su) ! S == BIGSTP & XTEMP == SU + mask_free = (s >= bigstp .and. .not. (mask_fixl .or. mask_fixu)) + s(trueloc(mask_fixl)) = sl(trueloc(mask_fixl)) - xopt(trueloc(mask_fixl)) + s(trueloc(mask_fixu)) = su(trueloc(mask_fixu)) - xopt(trueloc(mask_fixu)) + sfixsq = sfixsq + sum(s(trueloc(mask_fixl .or. mask_fixu))**2) + ggfree = sum(glag(trueloc(mask_free))**2) + if (.not. (sfixsq > ssqsav .and. ggfree > 0)) then + exit + end if + end do + + ! Set the remaining free components of S and all components of XCAUCHY. S may be scaled later. + x(trueloc(glag > 0)) = sl(trueloc(glag > 0)) + x(trueloc(glag <= 0)) = su(trueloc(glag <= 0)) + x(trueloc(abs(s) <= 0)) = xopt(trueloc(abs(s) <= 0)) + xtemp = max(sl, min(su, xopt - grdstp * glag)) + x(trueloc(s >= bigstp)) = xtemp(trueloc(s >= bigstp)) ! S == BIGSTP + s(trueloc(s >= bigstp)) = -grdstp * glag(trueloc(s >= bigstp)) ! S == BIGSTP + gs = inprod(glag, s) + + ! Set CURV to the curvature of the KNEW-th Lagrange function along S. Scale S by a factor less + ! than ONE if that can reduce the modulus of the Lagrange function at XOPT+S. Set CAUCHY to the + ! final value of the square of this function. + sxpt = matprod(s, xpt) + curv = inprod(sxpt, pqlag * sxpt) ! CURV = INPROD(S, HESS_MUL(S, XPT, PQLAG)) + if (uphill == 1) then + curv = -curv + end if + if (curv > -gs .and. curv < -(ONE + sqrt(TWO)) * gs) then + scaling = -gs / curv + x = max(sl, min(su, xopt + scaling * s)) + vlagsq = (HALF * gs * scaling)**2 + else + vlagsq = (gs + HALF * curv)**2 + end if + + if (vlagsq > vlagsq_cauchy) then + xcauchy = x + vlagsq_cauchy = vlagsq + end if +end do + +! Calculate the denominator rendered by the Cauchy step. Indeed, only DEN_CAUCHY(KNEW) is needed. +s = xcauchy - xopt +den_cauchy = calden(kopt, bmat, s, xpt, zmat) + +! Take the Cauchy step if it is likely to render a larger denominator. +!IF (VLAGSQ_CAUCHY > MAX(DEN_LINE(KNEW), ZERO) .OR. IS_NAN(DEN_LINE(KNEW))) THEN ! Powell's version +if (den_cauchy(knew) > max(den_line(knew), ZERO) .or. is_nan(den_line(knew))) then ! Works better + d = s +end if + +! In case D is zero or contains Inf/NaN, replace it with a displacement from XPT(:, KNEW) to XOPT. +! Powell's code does not have this. Note that it is crucial to ensure that a geometry step is nonzero. +if (sum(abs(d)) <= 0 .or. .not. is_finite(sum(abs(d)))) then + d = xpt(:, knew) - xopt + d = min(HALF, delbar / norm(d)) * d ! Since XPT respects the bounds, so does XOPT + D. +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(d) == n, 'SIZE(D) == N', srname) + call assert(all(is_finite(d)), 'D is finite', srname) + ! In theory, ||D|| <= DELBAR, which may be false due to rounding, but ||D|| >= 2*DELBAR is unlikely. + ! It is crucial to ensure that the geometry step is nonzero, which holds in theory. However, due + ! to the bound constraints, ||D|| may be much smaller than DELBAR. + call assert(norm(d) > 0 .and. norm(d) < TWO * delbar, '0 < ||D|| < 2*DELBAR', srname) + ! D is supposed to satisfy the bound constraints SL <= XOPT + D <= SU. + call assert(all(xopt + d >= sl - TEN * EPS * max(ONE, abs(sl)) .and. & + & xopt + d <= su + TEN * EPS * max(ONE, abs(su))), 'SL <= XOPT + D <= SU', srname) +end if + +end function geostep + + +end module geometry_bobyqa_mod diff --git a/examples/fortran/prima/native/bobyqa/initialize.f90 b/examples/fortran/prima/native/bobyqa/initialize.f90 new file mode 100644 index 000000000..995e96798 --- /dev/null +++ b/examples/fortran/prima/native/bobyqa/initialize.f90 @@ -0,0 +1,557 @@ +module initialize_bobyqa_mod +!--------------------------------------------------------------------------------------------------! +! This module performs the initialization of BOBYQA, described in Section 2 of the BOBYQA paper. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the BOBYQA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Tue 10 Feb 2026 01:53:25 PM CET +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: initxf, initq, inith + + +contains + + +subroutine initxf(calfun, iprint, maxfun, ftarget, rhobeg, xl, xu, x0, ij, kopt, nf, fhist, fval, & + & sl, su, xbase, xhist, xpt, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine does the initialization about the interpolation points & their function values. +! +! N.B.: +! 1. Remark on IJ: +! If NPT <= 2*N + 1, then IJ is empty. Assume that NPT >= 2*N + 2. Then SIZE(IJ) = [2, NPT-2*N-1]. +! IJ contains integers between 1 and N. For each K > 2*N + 1, XPT(:, K) is +! XPT(:, IJ(1, K) + 1) + XPT(:, IJ(2, K) + 1). The 1 in IJ + 1 comes from the fact that XPT(:, 1) +! corresponds to the base point XBASE. Let I = IJ(1, K) and J = IJ(2, K). Then all the +! entries of XPT(:, K) are zero except for the I and J entries. Consequently, the Hessian of the +! quadratic model will get a possibly nonzero (I, J) entry. +! 2. At return, +! INFO = INFO_DFT: initialization finishes normally +! INFO = FTARGET_ACHIEVED: return because F <= FTARGET +! INFO = NAN_INF_X: return because X contains NaN +! INFO = NAN_INF_F: return because F is either NaN or +Inf +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TWO, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: evaluate_mod, only : evaluate +use, non_intrinsic :: history_mod, only : savehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT +use, non_intrinsic :: message_mod, only : fmsg +use, non_intrinsic :: pintrf_mod, only : OBJ +use, non_intrinsic :: powalg_mod, only : setij +use, non_intrinsic :: xinbd_mod, only : xinbd + +implicit none + +! Inputs +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfun +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: xl(:) ! XL(N) +real(RP), intent(in) :: xu(:) ! XU(N) + +! In-outputs +real(RP), intent(inout) :: x0(:) ! X(N) + +! Outputs +integer(IK), intent(out) :: ij(:, :) ! IJ(2, MAX(0_IK, NPT-2*N-1_IK)) +integer(IK), intent(out) :: info +integer(IK), intent(out) :: kopt +integer(IK), intent(out) :: nf +real(RP), intent(out) :: fhist(:) +real(RP), intent(out) :: fval(:) ! FVAL(NPT) +real(RP), intent(out) :: sl(:) ! SL(N) +real(RP), intent(out) :: su(:) ! SU(N) +real(RP), intent(out) :: xbase(:) ! XBASE(N) +real(RP), intent(out) :: xhist(:, :) ! XHIST(N, MAXXHIST) +real(RP), intent(out) :: xpt(:, :) ! XPT(N, NPT) + +! Local variables +character(len=*), parameter :: solver = 'BOBYQA' +character(len=*), parameter :: srname = 'INITIALIZE' +integer(IK) :: k +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: npt +integer(IK) :: subinfo +logical :: evaluated(size(xpt, 2)) +real(RP) :: f +real(RP) :: x(size(xpt, 1)) + +! Sizes. +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxhist = int(max(maxxhist, maxfhist), kind(maxhist)) + +! Preconditions +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(npt >= n + 2, 'NPT >= N+2', srname) + call assert(rhobeg > 0, 'RHOBEG > 0', srname) + call assert(size(fval) == npt, 'SIZE(FVAL) == NPT', srname) + call assert(size(sl) == n .and. size(su) == n, 'SIZE(SL) == N == SIZE(SU)', srname) + call assert(size(xl) == n .and. size(xu) == n, 'SIZE(XL) == N == SIZE(XU)', srname) + call assert(size(x0) == n .and. all(is_finite(x0)), 'SIZE(X0) == N, X0 is finite', srname) + call assert(all(x0 >= xl .and. (x0 <= xl .or. x0 - xl >= rhobeg)), 'X0 == XL or X0 - XL >= RHOBEG', srname) + call assert(all(x0 <= xu .and. (x0 >= xu .or. xu - x0 >= rhobeg)), 'X0 == XU or XU - X0 >= RHOBEG', srname) + call assert(size(xbase) == n, 'SIZE(XBASE) == N', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialize INFO to the default value. At return, an INFO different from this value will indicate +! an abnormal return. +info = INFO_DFT + +! SL and SU are the lower and upper bounds on feasible moves from X0. +sl = xl - x0 +su = xu - x0 +! After the preprocessing subroutine PREPROC, SL <= 0 and the nonzero entries of SL should be less +! than -RHOBEG, while SU >= 0 and the nonzeros of SU should be larger than RHOBEG. However, this may +! not be true due to rounding. The following lines revise SL and SU to ensure it. X0 is also revised +! accordingly. In precise arithmetic, the "revisions" do not change SL, SU, or X0. +where (sl < 0) + sl = min(sl, -rhobeg) +elsewhere + x0 = xl + sl = ZERO + su = xu - xl +end where +where (su > 0) + su = max(su, rhobeg) +elsewhere + x0 = xu + sl = xl - xu + su = ZERO +end where +!!MATLAB code for revising X, SL, and SU: +!!sl(sl < 0) = min(sl(sl < 0), -rhobeg); +!!x0(sl >= 0) = xl(sl >= 0); +!!sl(sl >= 0) = 0; +!!su(sl >= 0) = xu(sl >= 0) - xl(sl >= 0); +!!su(su > 0) = max(su(su > 0), rhobeg); +!!x0(su <= 0) = xu(su <= 0); +!!sl(su <= 0) = xl(su <= 0) - xu(su <= 0); +!!su(su <= 0) = 0; + +! Initialize XBASE to X0. +xbase = x0 + +! EVALUATED is a boolean array with EVALUATED(I) indicating whether the function value of the I-th +! interpolation point has been evaluated. We need it for a portable counting of the number of +! function evaluations, especially if the loop is conducted asynchronously. +evaluated = .false. + +! Initialize XHIST, FHIST, and FVAL. Otherwise, compilers may complain that they are not +! (completely) initialized if the initialization aborts due to abnormality (see CHECKEXIT). +! N.B.: 1. Initializing them to NaN would be more reasonable (NaN is not available in Fortran). +! 2. Do not initialize the models if the current initialization aborts due to abnormality. Otherwise, +! errors or exceptions may occur, as FVAL and XPT etc are uninitialized. +xhist = -REALMAX +fhist = REALMAX +fval = REALMAX + +! Set XPT(:, 2 : N+1) +xpt = ZERO +do k = 1, n + xpt(k, k + 1) = rhobeg + if (su(k) <= 0) then ! SU(K) == 0 + xpt(k, k + 1) = -rhobeg + end if +end do +! Set XPT(:, N+2 : MIN(2*N + 1, NPT)). +do k = 1, min(npt - n - 1_IK, n) + xpt(k, k + n + 1) = -rhobeg + if (sl(k) >= 0) then ! SL(K) == 0 + xpt(k, k + n + 1) = min(TWO * rhobeg, su(k)) + end if + if (su(k) <= 0) then ! SU(K) == 0 + xpt(k, k + n + 1) = max(-TWO * rhobeg, sl(k)) + end if +end do + +! Set FVAL(1 : MIN(2*N + 1, NPT)) by evaluating F. Totally parallelizable except for FMSG. +do k = 1, min(npt, int(2 * n + 1, kind(npt))) + x = xinbd(xbase, xpt(:, k), xl, xu, sl, su) ! In precise arithmetic, X = XBASE + XPT(:, K). + call evaluate(calfun, x, f) + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Initialization', iprint, k, rhobeg, f, x) + ! Save X, F into the history. + call savehist(k, x, xhist, f, fhist) + + evaluated(k) = .true. + fval(k) = f + + ! Check whether to exit + subinfo = checkexit(maxfun, k, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if +end do + +! For the K between 2 and N + 1, switch XPT(:, K) and XPT(:, K+1) if XPT(K-1, K) and XPT(K-1, K+N) +! have different signs and FVAL(K) <= FVAL(K+N). This provides a bias towards potentially lower +! values of F when defining XPT(:, 2*N + 2 : NPT). We may drop the requirement on the signs, but +! Powell's code has such a requirement. +! N.B.: +! 1. The switching is OPTIONAL. If we remove it, then the evaluations of FVAL(1 : NPT) can be +! merged, and they are totally PARALLELIZABLE; this can be beneficial if the function evaluations +! are expensive, which is likely the case. +! 2. The initialization of NEWUOA revises IJ (see below) instead of XPT and FVAL. Theoretically, it +! is equivalent; practically, after XPT is revised, the initialization of the quadratic model and +! the Lagrange polynomials also needs revision, as, e.g., XPT(:, 2:N) is not RHOBEG*EYE(N) anymore. +do k = 2, min(npt - n, int(n + 1, kind(npt))) + if (xpt(k - 1, k) * xpt(k - 1, k + n) < 0 .and. fval(k + n) < fval(k)) then + fval([k, k + n]) = fval([k + n, k]) + xpt(:, [k, k + n]) = xpt(:, [k + n, k]) + ! Indeed, only XPT(K-1, [K, K+N]) needs switching, as the other entries are zero. + end if +end do + +! Set IJ. +! In general, when NPT = (N+1)*(N+2)/2, we can set IJ(:, 1 : NPT - (2*N+1)) to ANY permutation +! of {{I, J} : 1 <= I /= J <= N}; when NPT < (N+1)*(N+2)/2, we can set it to the first NPT - (2*N+1) +! elements of such a permutation. The following IJ is defined according to Powell's code. See also +! Section 3 of the NEWUOA paper and (2.4) of the BOBYQA paper. +ij = setij(n, npt) + +! Set XPT(:, 2*N + 2 : NPT). It depends on XPT(:, 1 : 2*N + 1) and hence on FVAL(1: 2*N + 1). +! Indeed, XPT(:, K) has only two nonzeros for each K >= 2*N+2. +! N.B.: The 1 in IJ + 1 comes from the fact that XPT(:, 1) corresponds to XBASE. +xpt(:, 2 * n + 2:npt) = xpt(:, ij(1, :) + 1) + xpt(:, ij(2, :) + 1) + +! Set FVAL(2*N + 2 : NPT) by evaluating F. Totally parallelizable except for FMSG. +if (info == INFO_DFT) then + do k = int(2 * n + 2, kind(k)), npt + x = xinbd(xbase, xpt(:, k), xl, xu, sl, su) ! In precise arithmetic, X = XBASE + XPT(:, K). + call evaluate(calfun, x, f) + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Initialization', iprint, k, rhobeg, f, x) + ! Save X, F into the history. + call savehist(k, x, xhist, f, fhist) + + evaluated(k) = .true. + fval(k) = f + + ! Check whether to exit + subinfo = checkexit(maxfun, k, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + end do +end if + +! Set NF, KOPT +nf = int(count(evaluated), kind(nf)) +kopt = int(minloc(fval, mask=evaluated, dim=1), kind(kopt)) +!!MATLAB: fopt = min(fval(evaluated)); kopt = find(evaluated & ~(fval > fopt), 1, 'first'); + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nf <= npt, 'NF <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(all(ij >= 1 .and. ij <= n), '1 <= IJ <= N', srname) + call assert(all(ij(1, :) /= ij(2, :)), 'IJ(1, :) /= IJ(2, :)', srname) + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(all(xbase >= xl .and. xbase <= xu), 'XL <= XBASE <= XU', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(all(xpt >= spread(sl, dim=2, ncopies=npt)) .and. & + & all(xpt <= spread(su, dim=2, ncopies=npt)), 'SL <= XPT <= SU', srname) + call assert(size(fval) == npt .and. .not. any(evaluated .and. (is_nan(fval) .or. is_posinf(fval))), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(.not. any(evaluated .and. fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + do k = 1, min(nf, maxxhist) + call assert(all(xhist(:, k) >= xl) .and. all(xhist(:, k) <= xu), 'XL <= XHIST <= XU', srname) + end do +end if + +end subroutine initxf + + +subroutine initq(ij, fval, xpt, gopt, hq, pq, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine initializes the quadratic model represented by [GOPT, HQ, PQ] so that its gradient +! at XBASE + XPT(:, KOPT) is GOPT; its Hessian is HQ + sum_{K=1}^NPT PQ(K)*XPT(:, K)*XPT(:, K)'. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TWO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: infos_mod, only : INFO_DFT, NAN_INF_MODEL +use, non_intrinsic :: linalg_mod, only : issymmetric, diag, matprod + +implicit none + +! Inputs +integer(IK), intent(in) :: ij(:, :) ! IJ(2, MAX(0_IK, NPT-2*N-1_IK)) +real(RP), intent(in) :: fval(:) ! FVAL(NPT) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +integer(IK), intent(out), optional :: info +real(RP), intent(out) :: gopt(:) ! GOPT(N) +real(RP), intent(out) :: hq(:, :) ! HQ(N, N) +real(RP), intent(out) :: pq(:) ! PQ(NPT) + +! Local variables +character(len=*), parameter :: srname = 'INITQ' +integer(IK) :: i +integer(IK) :: j +integer(IK) :: k +integer(IK) :: kopt +integer(IK) :: n +integer(IK) :: ndiag +integer(IK) :: npt +real(RP) :: fbase +real(RP) :: xa(min(size(xpt, 1), size(xpt, 2) - size(xpt, 1) - 1)) +real(RP) :: xb(size(xa)) +real(RP) :: xi +real(RP) :: xj + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(all(ij >= 1 .and. ij <= n), '1 <= IJ <= N', srname) + call assert(all(ij(1, :) /= ij(2, :)), 'IJ(1, :) /= IJ(2, :)', srname) + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. size(hq, 2) == n, 'SIZE(HQ) = [N, N]', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +fbase = fval(1) ! FBASE is the function value at XBASE. + +! Set GOPT by the forward difference. +gopt = (fval(2:n + 1) - fbase) / diag(xpt(:, 2:n + 1)) + +! The interpolation conditions decide GOPT(1:NDIAG) and the first NDIAG diagonal 2nd derivatives of +! the initial quadratic model by a quadratic interpolation on three points. +ndiag = min(n, npt - n - 1_IK) +xa = diag(xpt(:, 2:ndiag + 1)) +xb = diag(xpt(:, n + 2:n + ndiag + 1)) + +! Revise GOPT(1:NDIAG) to the value provided by the three-point interpolation. +gopt(1:ndiag) = (gopt(1:ndiag) * xb - ((fval(n + 2:n + ndiag + 1) - fbase) / xb) * xa) / (xb - xa) + +! Set the diagonal of HQ by the three-point interpolation. If we do this before the revision of +! GOPT(1:NDIAG), we can avoid the calculation of FVAL(K + 1) - FBASE) / RHOBEG. But we prefer to +! decouple the initialization of GOPT and HQ. We are not concerned by this amount of flops. +hq = ZERO +do k = 1, ndiag + hq(k, k) = TWO * ((fval(k + 1) - fbase) / xa(k) - (fval(n + k + 1) - fbase) / xb(k)) / (xa(k) - xb(k)) +end do +!!MATLAB: +!!hdiag = 2*((fval(2 : ndiag+1) - fbase) / xa - (fval(n+2 : n+ndiag+1) - fbase) / xb) / (xa-xb) +!!hq(1:ndiag, 1:ndiag) = diag(hdiag) + +! When NPT > 2*N + 1, set the off-diagonal entries of HQ. +do k = 1, npt - 2_IK * n - 1_IK + i = ij(1, k) + j = ij(2, k) + xi = xpt(i, k + 2 * n + 1) + xj = xpt(j, k + 2 * n + 1) + ! N.B.: The 1 in I+1 and J+1 comes from the fact that XPT(:, 1) corresponds to XBASE. + hq(i, j) = (fbase - fval(i + 1) - fval(j + 1) + fval(k + 2 * n + 1)) / (xi * xj) + hq(j, i) = hq(i, j) +end do + +kopt = int(minloc(fval, dim=1), kind(kopt)) +if (kopt /= 1) then + gopt = gopt + matprod(hq, xpt(:, kopt)) +end if + +pq = ZERO + +if (present(info)) then + if (any(is_nan(gopt)) .or. any(is_nan(hq))) then + info = NAN_INF_MODEL + else + info = INFO_DFT + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) +end if + +end subroutine initq + + +subroutine inith(ij, xpt, bmat, zmat, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine initializes [BMAT, ZMAT] which represents the matrix H in (2.7) of the BOBYQA +! paper (see also (3.12) of the NEWUOA paper). +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, NAN_INF_MODEL +use, non_intrinsic :: linalg_mod, only : issymmetric, diag +!use, non_intrinsic :: powalg_mod, only : errh + +implicit none + +! Inputs +integer(IK), intent(in) :: ij(:, :) ! IJ(2, MAX(0_IK, NPT-2*N-1_IK)) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +integer(IK), intent(out), optional :: info +real(RP), intent(out) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(out) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Local variables +character(len=*), parameter :: srname = 'INITH' +integer(IK) :: k +integer(IK) :: n +integer(IK) :: ndiag +integer(IK) :: npt +real(RP) :: rhobeg +real(RP) :: rhosq +real(RP) :: xa(min(size(xpt, 1), size(xpt, 2) - size(xpt, 1) - 1)) +real(RP) :: xb(size(xa)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(all(ij >= 1 .and. ij <= n), '1 <= IJ <= N', srname) + call assert(all(ij(1, :) /= ij(2, :)), 'IJ(1, :) /= IJ(2, :)', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Some values to be used for setting BMAT and ZMAT. +rhobeg = maxval(abs(xpt(:, 2))) ! Read RHOBEG from XPT. Note that XPT(:, 1) = 0. +rhosq = rhobeg**2 + +! The interpolation set decides the first NDIAG diagonal 2nd derivatives of the Lagrange polynomials. +ndiag = min(n, npt - n - 1_IK) +xa = diag(xpt(:, 2:ndiag + 1)) +xb = diag(xpt(:, n + 2:n + ndiag + 1)) + +bmat = ZERO +! Set BMAT(1 : NDIAG, :) +bmat(1:ndiag, 1) = -(xa + xb) / (xa * xb) +do k = 1, ndiag + bmat(k, k + n + 1) = -HALF / xpt(k, k + 1) + bmat(k, k + 1) = -bmat(k, 1) - bmat(k, k + n + 1) +end do +! Set BMAT(NDIAG+1 : N, :) +do k = ndiag + 1_IK, n + bmat(k, 1) = -ONE / xpt(k, k + 1) + bmat(k, k + 1) = -bmat(k, 1) + bmat(k, npt + k) = -HALF * rhosq +end do + +zmat = ZERO +! Set ZMAT(:, 1 : NDIAG) +zmat(1, 1:ndiag) = sqrt(TWO) / (xa * xb) +do k = 1, ndiag + zmat(k + 1, k) = -zmat(1, k) - sqrt(HALF) / rhosq + zmat(k + n + 1, k) = sqrt(HALF) / rhosq +end do +! Set ZMAT(:, NDIAG+1 : NPT-N-1) +do k = ndiag + 1_IK, npt - n - 1_IK + zmat(1, k) = ONE / rhosq + zmat(k + n + 1, k) = ONE / rhosq + zmat(ij(:, k - n) + 1, k) = -ONE / rhosq +end do + +if (present(info)) then + if (any(is_nan(bmat)) .or. any(is_nan(zmat))) then + info = NAN_INF_MODEL + else + info = INFO_DFT + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + !call assert(errh(1_IK, bmat, zmat, xpt) <= max(1.0E-3_RP, 1.0E2_RP * real(npt, RP) * EPS) .or. & + ! & precision(0.0_RP) < precision(0.0D0), '[BMA, ZMAT] represents H = W^{-1}', srname) +end if + +end subroutine inith + + +end module initialize_bobyqa_mod diff --git a/examples/fortran/prima/native/bobyqa/rescue.f90 b/examples/fortran/prima/native/bobyqa/rescue.f90 new file mode 100644 index 000000000..382d47fb5 --- /dev/null +++ b/examples/fortran/prima/native/bobyqa/rescue.f90 @@ -0,0 +1,803 @@ +module rescue_mod +!--------------------------------------------------------------------------------------------------! +! This module contains the RESCUE subroutine described in Section 5 of the BOBYQA paper. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the BOBYQA paper. +! +! N.B.: +! 1. According to a test on 20220425, the invocations of RESCUE is rare --- it is never invoked +! on CUTEst unconstrained or bound constrained problems with at most 50 variables unless heavy noise +! is imposed on the function evaluation. +! 2. Zaikun (20230321): According to a test on 20230321 on problems of at most 200 variables, it +! affects (not necessarily worsen) the performance of BOBYQA quite marginally if RESCUE is +! completely disabled. Therefore, in the first implementation of an algorithm based on the +! derivative-free PSB, it seems safe to ignore RESCUE. It is similar for the IDZ technique of +! NEWUOA/LINCOA. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Thu 14 Aug 2025 07:34:53 AM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: rescue + + +contains + + +subroutine rescue(calfun, solver, iprint, maxfun, delta, ftarget, xl, xu, kopt, nf, fhist, fval, & + & gopt, hq, pq, sl, su, xbase, xhist, xpt, bmat, zmat, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine implements "the method of RESCUE" introduced in Section 5 of BOBYQA paper. The +! purpose of this subroutine is to replace a few interpolation points by new points in order to +! improve the geometry of the interpolation set and the conditioning of the interpolation system. +! This is done in the following way. +! +! 1. Define a set of "provisional interpolation points" XPT_PROV around the current XOPT. Similar to +! the construction of the initial interpolation set, XPT_PROV is obtained by perturbing XOPT subject +! to the bound constraints along one or two coordinate directions, the latter taking place only if +! NPT >= 2*N+2. See (5.4)--(5.5) of the BOBYQA paper for details. After defining XPT_PROV, set BMAT +! and ZMAT to represent the H matrix defined in (2.7) of the BOBYQA paper corresponding to XPT_PROV. +! N.B.: In the code, XPT_PROV is not formed explicitly, but represented implicitly by XPT, PTSID, +! and PTSAUX. +! 2. For each "original interpolation point" in XPT, check whether it can replace a point in XPT_PROV +! without damaging the geometry of XPT_PROV, which is indicated by the denominator SIGMA in the +! updating formula of H due to the replacement (see (4.9) of the BOBYQA paper). If yes, update +! XPT_PROV by the performing such an replacement. Continue doing this until all the original points +! get reinstated in XPT_PROV, or we cannot find any original point that can safely replace +! a provisional point. Note the following. +! 2.1. Suppose that the KORIG-th original point is going to replace the KPROV-th provisional point. +! Then we first exchange the KORIG-th and KPROV-th provisional points, and then replace the new +! KORIG-th provisional point by the KORIG-th original point. BMAT and ZMAT are updated accordingly. +! In this way, FVAL(KORIG) is consistent with XPT_PROV(:, KORIG), so that we need not update FVAL. +! 2.1. The KOPT-th original point (i.e., XOPT) is always reinstated in XPT_PROV. This is done by +! replacing XPT_PROV(:, 1) with XOPT. This is the first replacement to perform. +! 2.2. After XOPT is reinstated, the original points are ranked according the scores saved in SCORE. +! SCORE is initialized to the squares of the distances from between the original point and XOPT. +! The KORIG is set to the index of the point with the smallest positive score. If XPT(:, KORIG) +! cannot replace any provisional point safely, then set SCORE(KORIG) to -SCORE(KORIG) - SCOREINC; +! otherwise, set SCORE(KORIG) to 0 and all the other scores to their absolute values. In this way, +! an original point that fails to replace any provisional point during the current attempt will be +! skipped until another original point succeeds in doing so; moreover, the failing point will get +! a lower priority in later attempts. An original point that successfully replaces a provisional +! point will not be tried again due to the zero score. +! 2.3. Once a provisional point is replaced, it will be marked (by setting the corresponding entry +! of PTSID to zero) so that it will not be replaced again. +! 3. When the above procedure finishes, normally most original points are reinstated in XPT_PROV, so +! that XPT_PROV differs from XPT only at very few positions. Set XPT to XPT_PROV, update FVAL at the +! new interpolation points by evaluating F, and then quadratic interpolant [GQ, PQ, HQ] accordingly. +! +! At the end of the subroutine, the elements of BMAT and ZMAT are set in a well-conditioned way to +! the values that are appropriate for the new interpolation points. The elements of GOPT, HQ and PQ +! are also revised to the values that are appropriate to the final quadratic model. +! +! The arguments NF, KOPT, XL, XU, IPRINT, MAXFUN, XBASE, XPT, FVAL GOPT, HQ, PQ, BMAT, ZMAT, SL +! and, SU have the same meanings as the corresponding arguments of BOBYQB on the entry to RESCUE. +! DELTA is the current trust region radius. +! PTSAUX is a 2-by-N real array. For J = 1, 2, ..., N, PTSAUX(1, J) and PTSAUX(2, J) specify the two +! positions of provisional interpolation points when a nonzero step is taken along e_J (the J-th +! coordinate direction) through XBASE + XOPT, as specified below. Usually these steps have length +! DELTA, but other lengths are chosen if necessary in order to satisfy the bound constraints. +! PTSID is an integer array of length NPT. Its components denote provisional new positions of the +! interpolation points. The K-th point is a candidate for change if and only if PTSID(K) is +! nonzero. In this case let IP and IQ be the integer parts of PTSID(K) and (PTSID(K)-IP)*(N+1). If +! IP and IQ are both positive, the step from XBASE + XOPT to the new K-th interpolation point is +! PTSAUX(1, IP)*e_IP + PTSAUX(1, IQ)*e_IQ. Otherwise the step is either PTSAUX(1, IP)*e_IP or +! PTSAUX(2, IQ)*e_IQ in the cases IQ=0 or IP=0, respectively. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: evaluate_mod, only : evaluate +use, non_intrinsic :: history_mod, only : savehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : MAXFUN_REACHED, INFO_DFT +use, non_intrinsic :: linalg_mod, only : issymmetric, matprod, inprod, r1update, r2update, trueloc +use, non_intrinsic :: message_mod, only : fmsg +use, non_intrinsic :: pintrf_mod, only : OBJ +use, non_intrinsic :: powalg_mod, only : hess_mul, setij +use, non_intrinsic :: string_mod, only : num2str +use, non_intrinsic :: xinbd_mod, only : xinbd + +implicit none + +! Inputs +procedure(OBJ) :: calfun +character(len=*), intent(in) :: solver +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfun +real(RP), intent(in) :: delta +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: xl(:) ! XL(N) +real(RP), intent(in) :: xu(:) ! XU(N) + +! In-outputs +integer(IK), intent(inout) :: kopt +integer(IK), intent(inout) :: nf +real(RP), intent(inout) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(inout) :: fval(:) ! FVAL(NPT) +real(RP), intent(inout) :: gopt(:) ! GOPT(N) +real(RP), intent(inout) :: hq(:, :) ! HQ(N, N) +real(RP), intent(inout) :: pq(:) ! PQ(NPT) +real(RP), intent(inout) :: sl(:) ! SL(N) +real(RP), intent(inout) :: su(:) ! SU(N) +real(RP), intent(inout) :: xbase(:) ! XBASE(N) +real(RP), intent(inout) :: xhist(:, :) ! XHIST(N, MAXXHIST) +real(RP), intent(inout) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +integer(IK), intent(out) :: info +real(RP), intent(out) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(out) :: zmat(:, :) ! ZMAT(NPT, NPT-N-1) + +! Local variables +character(len=*), parameter :: srname = 'RESCUE' +integer(IK) :: ij(2, max(0, size(xpt, 2) - 2 * size(xpt, 1) - 1)) +integer(IK) :: ip +integer(IK) :: iq +integer(IK) :: iter +integer(IK) :: j +integer(IK) :: k +integer(IK) :: kbase +integer(IK) :: korig +integer(IK) :: kprov +integer(IK) :: kpt +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxiter +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: nprov +integer(IK) :: npt +integer(IK) :: subinfo +logical :: mask(size(xpt, 1)) +real(RP) :: beta +real(RP) :: bsum +real(RP) :: den(size(xpt, 2)) +real(RP) :: f +real(RP) :: fbase +real(RP) :: hcol(size(bmat, 2)) +real(RP) :: hdiag(size(xpt, 2)) +real(RP) :: moderr +real(RP) :: pqinc(size(xpt, 2)) +real(RP) :: ptsaux(2, size(xpt, 1)) +real(RP) :: ptsid(size(xpt, 2)) +real(RP) :: score(size(xpt, 2)) +real(RP) :: scoreinc +real(RP) :: sfrac +real(RP) :: temp +real(RP) :: v(size(xpt, 1)) +real(RP) :: vlag(size(xpt, 1) + size(xpt, 2)) +real(RP) :: vquad +real(RP) :: wmv(size(xpt, 1) + size(xpt, 2)) +real(RP) :: x(size(xpt, 1)) +real(RP) :: xnew(size(xpt, 1)) +real(RP) :: xopt(size(xpt, 1)) +real(RP) :: xp +real(RP) :: xq +real(RP) :: xxpt(size(xpt, 2)) + +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxhist = int(max(maxxhist, maxfhist), kind(maxhist)) + +! Preconditions +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(npt >= n + 2, 'NPT >= N+2', srname) + call assert(maxfun >= npt + 1, 'MAXFUN >= NPT+1', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(delta > 0, 'DELTA > 0', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN/+Inf', srname) + call assert(.not. any(fval < fval(kopt)), 'FVAL(KOPT) is the smallest in FVAL', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(size(xl) == n .and. size(xu) == n, 'SIZE(XL) == N == SIZE(XU)', srname) + call assert(size(sl) == n .and. all(sl <= 0), 'SIZE(SL) == N, SL <= 0', srname) + call assert(size(su) == n .and. all(su >= 0), 'SIZE(SU) == N, SU >= 0', srname) + call assert(size(gopt) == n, 'SIZE(GOPT) == N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is n-by-n and symmetric', srname) + call assert(size(pq) == npt, 'SIZE(PQ) == NPT', srname) + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(all(xbase >= xl .and. xbase <= xu), 'XL <= XBASE <= XU', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(all(is_finite(xhist(:, 1:min(nf, maxxhist)))), 'XHIST is finite', srname) + do k = 1, min(nf, maxxhist) + call assert(all(xhist(:, k) >= xl) .and. all(xhist(:, k) <= xu), 'XL <= XHIST <= XU', srname) + end do + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(all(xpt >= spread(sl, dim=2, ncopies=npt)) .and. & + & all(xpt <= spread(su, dim=2, ncopies=npt)), 'SL <= XPT <= SU', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT) == [N, NPT+N]', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1_IK, 'SIZE(ZMAT) == [NPT, NPT-N-1]', srname) + call assert(maxhist >= 0 .and. maxhist <= maxfun, '0 <= MAXHIST <= MAXFUN', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +info = INFO_DFT + +! Do nothing if NF already reaches it upper bound. +! To please Fortran compilers, set BMAT and ZMAT before returning, though they will not be used. +if (nf >= maxfun) then + bmat = ZERO + zmat = ZERO + info = MAXFUN_REACHED + return +end if + +! Shift the interpolation points so that XOPT becomes the origin. +xopt = xpt(:, kopt) +sl = min(sl - xopt, ZERO) +su = max(su - xopt, ZERO) +xbase = min(max(xl, xbase + xopt), xu) +xpt = xpt - spread(xopt, dim=2, ncopies=npt) +xpt(:, kopt) = ZERO + +! Update HQ so that HQ and PQ define the second derivatives of the model after XBASE has been +! shifted to the trust region centre. +v = matprod(xpt, pq) + HALF * sum(pq) * xopt +call r2update(hq, ONE, xopt, v) + +! Set the elements of PTSAUX. +ptsaux(1, :) = min(delta, su) +ptsaux(2, :) = max(-delta, sl) +mask = (ptsaux(1, :) + ptsaux(2, :) < 0) +ptsaux([1, 2], trueloc(mask)) = ptsaux([2, 1], trueloc(mask)) +mask = (abs(ptsaux(2, :)) < HALF * abs(ptsaux(1, :))) +ptsaux(2, trueloc(mask)) = HALF * ptsaux(1, trueloc(mask)) + +! Set the identifiers of the artificial interpolation points that are along a coordinate direction +! from XOPT, and set the corresponding nonzero elements of BMAT and ZMAT. +sfrac = HALF / real(n + 1, RP) +ptsid(1) = sfrac +bmat = ZERO +zmat = ZERO +do k = 1, n + ptsid(k + 1) = real(k, RP) + sfrac + if (k <= npt - n - 1) then + ptsid(k + n + 1) = real(k, RP) / real(n + 1, RP) + sfrac + temp = ONE / (ptsaux(1, k) - ptsaux(2, k)) + bmat(k, k + 1) = -temp + ONE / ptsaux(1, k) + bmat(k, k + n + 1) = temp + ONE / ptsaux(2, k) + bmat(k, 1) = -bmat(k, k + 1) - bmat(k, k + n + 1) + zmat(1, k) = sqrt(TWO) / abs(ptsaux(1, k) * ptsaux(2, k)) + zmat(k + 1, k) = zmat(1, k) * ptsaux(2, k) * temp + zmat(k + n + 1, k) = -zmat(1, k) * ptsaux(1, k) * temp + else + bmat(k, 1) = -ONE / ptsaux(1, k) + bmat(k, k + 1) = ONE / ptsaux(1, k) + bmat(k, k + npt) = -HALF * ptsaux(1, k)**2 + end if +end do + +! Set any remaining identifiers with their nonzero elements of ZMAT. +ij = setij(n, npt) +do k = 2_IK * n + 2_IK, npt + ip = ij(1, k - 2 * n - 1) + iq = ij(2, k - 2 * n - 1) + ptsid(k) = real(ip, RP) + real(iq, RP) / real(n + 1, RP) + sfrac + temp = ONE / (ptsaux(1, ip) * ptsaux(1, iq)) + zmat([1_IK, k], k - n - 1) = temp + zmat([ip + 1, iq + 1], k - n - 1) = -temp +end do + +! Update BMAT, ZMAT, ans PTSID so that the 1st and the KOPT-th provisional points are exchanged. +! After the exchanging, the KOPT-th point in the provisional set becomes the zero vector, which is +! exactly the KOPT-th original point (after the shift of XBASE at the beginning of the subroutine). +if (kopt /= 1) then + bmat(:, [1_IK, kopt]) = bmat(:, [kopt, 1_IK]) + zmat([1_IK, kopt], :) = zmat([kopt, 1_IK], :) +end if +ptsid(1) = ptsid(kopt) +ptsid(kopt) = ZERO + +! The squares of the distances from XOPT to the other interpolation points are set at SCORE, which +! will be used to define the index KORIG in the loop below. Increments of SCOREINC may be added +! later to these scores to balance the consideration of the choice of point that is going to become +! current. Note that, in Powell's BOBYQA code, the initial scores are the squares of the distances, +! but there is no square in the BOBYQA paper (see the paragraph between (5.9) and (5.10) of the +! BOBYQA paper). The latter seem to work better in a test on 20221125. +!score = sum(xpt**2, dim=1) ! Powell's BOBYQA code +score = sqrt(sum(xpt**2, dim=1)) ! Powell's BOBYQA paper +! In theory, SCORE(KOPT) = 0. Make sure this so that KOPT will be skipped when we choose KORIG below. +score(kopt) = ZERO +scoreinc = maxval(score) + +! NPROV is the number of provisional points that has not yet been replaced with original points. +nprov = npt - 1_IK + +! Even without an upper bound for the loop counter, the following loop runs for at most NPT^2 times: +! for each value of NPROV, we need at most NPT loops to find an original point that can safely +! replace a provisional point; if such a pair of origin and provisional points are found, then NPROV +! will de reduced by 1; otherwise, SCORE will become all zero or negative, and the loop will exit. +! Originally, it is a WHILE loop, but we change it to a DO loop to avoid infinite cycling. +! N.B.: Overflow will occur in NPT^2 if NPT > 180 and IK = 16. The following is a workaround, which +! is **not needed in Python/MATLAB/Julia/R. In MATLAB, we can just take maxiter = npt^2**. +maxiter = int(min(10**min(range(0), range(0_IK)), int(npt)**2), IK) !!MATLAB: maxiter = npt^2; +do iter = 1, maxiter + ! !DO WHILE (ANY(SCORE > 0) .AND. NPROV > 1) ! WHILE version. + ! !IF (ALL(SCORE <= 0) .AND. NPROV <= 0) THEN ! Powell's code. May not take any provisional point. + ! !IF (ALL(SCORE <= 0) .AND. NPROV <= 2) THEN ! Retain at least two provisional points. + if (all(score <= 0) .or. nprov <= 1) then ! Retain at least one provisional point. + exit + end if + + ! Pick the index KORIG of an original point that has not yet replaced one of the provisional + ! points, giving attention to the closeness to XOPT and to previous tries with KORIG. + korig = int(minloc(score, mask=(score > 0), dim=1), kind(korig)) + + ! Calculate VLAG and BETA for the required updating of the H matrix if XPT(:, KORIG) is + ! reinstated in the set of interpolation points, which means to replace a point in the + ! following provisional interpolation set XPT_PROV defined in (5.4)--(5.5) of the BOBYQA paper. + ! 1. XPT_PROV(:, KOPT) = 0; + ! 2. For each K /= KOPT, if PTSID(K) == 0, then XPT_PROV(:, K) = XPT(:, K); if PTSID(K) > 0, + ! then XPT_PROV(:, K) has nonzeros only at IP (if IP > 0), IQ (if IQ > 0) positions, where IP + ! and IQ are the P(J) and Q(J) defined in and below (2.4) of the BOBYQA paper. + + ! First, form the (W - V) vector for XPT(:, KORIG). + ! In the code below, WMV = W - V = w(XNEW) - w(XOPT) without the (NPT+1)th entry, where + ! XNEW = XPT(:, KORIG), XOPT = XPT_PROV = 0, and w(.) is defined by (6.3) of the NEWUOA paper + ! (as well as (4.10) of the BOBYQA paper). Since XOPT = 0, we see from (6.3) that w(XOPT)(K) = 0 + ! for all K except that w(XOPT)(NPT+1) = 1. Thus WMV is the same at w(XNEW) without the + ! (NPT+1)-th entry. Therefore, WMV= [HALF*MATPROD(XNEW, XPT_PROV)**2, XNEW]. + do k = 1, npt + if (k == kopt) then + wmv(k) = ZERO + else if (ptsid(k) <= 0) then ! Indeed, PTSID >= 0. So PTSID(K) <= 0 means PTSID(K) = 0. + wmv(k) = inprod(xpt(:, korig), xpt(:, k)) + else + ip = floor(ptsid(k), kind(ip)) ! IP = 0 if 0 < PTSID(K) < 1. + iq = floor(real(n + 1, RP) * ptsid(k) - real((n + 1) * ip, RP), kind(iq)) + call assert(ip >= 0 .and. ip <= npt .and. iq >= 0 .and. iq <= npt, '0 <= IP, IQ <= NPT', srname) + if (ip > 0 .and. iq > 0) then + wmv(k) = xpt(ip, korig) * ptsaux(1, ip) + xpt(iq, korig) * ptsaux(1, iq) + elseif (ip > 0) then + wmv(k) = xpt(ip, korig) * ptsaux(1, ip) + elseif (iq > 0) then + wmv(k) = xpt(iq, korig) * ptsaux(2, iq) + else + wmv(k) = ZERO + end if + end if + wmv(k) = HALF * wmv(k) * wmv(k) + end do + wmv(npt + 1:npt + n) = xpt(:, korig) + + ! Now calculate VLAG = H*WMV + e_KOPT according to (4.26) of the NEWUOA paper except VLAG(KOPT). + vlag(1:npt) = matprod(zmat, matprod(wmv(1:npt), zmat)) + matprod(wmv(npt + 1:npt + n), bmat(:, 1:npt)) + vlag(npt + 1:npt + n) = matprod(bmat, wmv(1:npt + n)) + + ! Now calculate BETA. According to (4.12) of the NEWUOA paper (also (4.10) of the BOBYQA paper), + ! BETA = HALF*||XNEW - XOPT||^4 - WMV'*H*WMV. To calculate WMX'*H*WMV, note that + ! WMV'*H*WMV = WMV' * [Z*Z', B2^T; B1, B2] * WMV with Z = ZMAT, B1 = BMAT(:, 1:NPT), and + ! B2 = BMAT(:, NPT+1:NPT+N). Denoting W1 = WMV(1:NPT) and W2 = WMV(NPT+1:NPT+N), we then have + ! WMV'*H*WMV = ||W1'*Z||^2 + 2*W1'*B1*W2 + W1'*B2*W2 = ||W1'*Z||^2 + W1'(B1*W2 + [B1, B2]*WMV). + bsum = inprod(wmv(1:n), matprod(bmat(:, 1:npt), wmv(1:npt)) + matprod(bmat, wmv)) + beta = HALF * sum(xpt(:, korig)**2)**2 - sum(matprod(wmv(1:npt), zmat)**2) - bsum + + ! Finally, set VLAG(KOPT) to the correct value. + vlag(kopt) = vlag(kopt) + ONE + + ! For all K with PTSID(K) > 0, calculate the denominator DEN(K) = SIGMA in the updating formula + ! of H for XPT(:, KORIG) to replace XPT_PROV(:, K). + den = ZERO + hdiag(trueloc(ptsid > 0)) = sum(zmat(trueloc(ptsid > 0), :)**2, dim=2) + den(trueloc(ptsid > 0)) = hdiag(trueloc(ptsid > 0)) * beta + vlag(trueloc(ptsid > 0))**2 + + ! Attempt setting KPROV to the index of the provisional point to be replaced with the KORIG-th + ! original interpolation point. We choose KPROV by maximizing DEN(KPROV), which will be the + ! denominator SIGMA in the updating formula (4.9). In order to avoid a small denominator, we + ! consider it proper to replace the KPROV-th provisional point with the KORIG-th original point + ! only if DEN(KPROV) = MAXVAL(DEN) > C*MAXVAL(VLAG(1:NPT)**2), where C is a relatively small + ! positive constant --- C = 1 is achievable if the rounding errors were not severe; Powell took + ! C = 0.01, which prefers strongly the original point to the provisional (new) point, as the + ! latter necessitate new function evaluations. If this inequality is not achievable for the + ! current KORIG, then we will update SCORE(KORIG) to a negative value and continue the loop with + ! the next KORIG, which is set to MINLOC(SCORE, MASK=(SCORE > 0)) at the beginning of the loop, + ! skipping the original interpolation points with a nonpositive score. When a KORIG rendering + ! the aforesaid inequality is found, SCORE(KORIG) will be set to zero, and all the scores will + ! be reset to their absolute values, so that future attempts will try the original points that + ! have not succeeded in replacing a provisional point. The update of SCORE reflects an adaptive + ! ranking of the original points: points that are closer to XOPT have higher priority, and a + ! point will be ranked lower if it fails to fulfill MAXVAL(DEN) > C*MAXVAL(VLAG(1:NPT)**2). + ! Even if KORIG cannot satisfy this condition for now, it may validate the inequality in future + ! attempts, as BMAT and ZMAT will be updated. + if (.not. (is_finite(sum(abs(vlag))) .and. any(den > 5.0E-2_RP * maxval(vlag(1:npt)**2)))) then + ! The above condition works a bit better than Powell's version below due to the factor 0.05. + ! !IF (.NOT. (ANY(DEN > 1.0E-2_RP * MAXVAL(VLAG(1:NPT)**2)))) THEN ! Powell' code + score(korig) = -score(korig) - scoreinc + cycle + end if + kprov = int(maxloc(den, mask=(.not. is_nan(den)), dim=1), kind(kprov)) + !!MATLAB: [~, kprov] = max(den, [], 'omitnan'); + + ! Update BMAT, ZMAT, VLAG, and PTSID to exchange the KPROV-th and KORIG-th provisional points. + ! After the exchanging, the KORIG-th original point will replace the KORIG-th provisional point. + if (kprov /= korig) then + bmat(:, [kprov, korig]) = bmat(:, [korig, kprov]) + zmat([kprov, korig], :) = zmat([korig, kprov], :) + vlag([kprov, korig]) = vlag([korig, kprov]) + end if + ptsid(kprov) = ptsid(korig) + + ! Set PTSID(KORIG) = 0 so that the KORIG-th provisional point (after the exchanging) will be + ! skipped in the later loops. + ptsid(korig) = ZERO + ! Set SCORE(KORIG) = 0 so that the KORIG-th original point will be skipped in later loops. + score(korig) = ZERO + ! Reset SCORE to ABS(SCORE) so that all the original points with a nonzero score will be checked + ! in later loops. + score = abs(score) + + ! Update the BMAT and ZMAT matrices so that the KORIG-th original point replaces the KORIG-th + ! provisional point. + call updateh_rsc(korig, beta, vlag, bmat, zmat) + + ! NPROV is the number of provisional points that has not yet been replaced with original points. + nprov = nprov - 1_IK +end do + +! All the final positions of the interpolation points have been chosen although any changes have not +! been included yet in XPT. Also the final BMAT and ZMAT matrices are complete, but, apart from the +! shift of XBASE, the updating of the quadratic model remains to be done. The following cycle +! through the new interpolation points begins by putting the new point in XPT(:, KPT) and by setting +! PQ(KPT) to zero. A return occurs if MAXFUN prohibits another value of F or when all the new +! interpolation points are included in the model. +kbase = kopt +fbase = fval(kopt) +if (nprov > 0) then + do kpt = 1, npt + if (ptsid(kpt) <= 0) then + cycle + end if + + ! Absorb PQ(KPT)*XPT(:, KPT)*XPT(:, KPT)^T into the explicit part of the Hessian of the + ! quadratic model. Implement R1UPDATE properly so that it ensures HQ is symmetric. + call r1update(hq, pq(kpt), xpt(:, kpt)) + pq(kpt) = ZERO + + ip = floor(ptsid(kpt), kind(ip)) + iq = floor(real(n + 1, RP) * ptsid(kpt) - real((n + 1) * ip, RP), kind(iq)) + + ! Update XPT(:, KPT) to the new point. It contains at most two nonzeros XP and XQ at the IP + ! and IQ entries. + xp = ZERO + xq = ZERO + xnew = ZERO + if (ip > 0 .and. iq > 0) then + xp = ptsaux(1, ip) + xnew(ip) = xp + xq = ptsaux(1, iq) + xnew(iq) = xq + elseif (ip > 0) then ! IP > 0, IQ == 0 + xp = ptsaux(1, ip) + xnew(ip) = xp + elseif (iq > 0) then ! IP == 0, IQ > 0 + xq = ptsaux(2, iq) + xnew(iq) = xq + end if + + ! Zaikun 20240314: Skip the new point if it is too close to XPT(:, KPT), the point to replace. + ! Indeed, it may even happen that XNEW == XPT(:, KPT), which did occur when RP = REAL16 (half + ! precision) and led to an infinite cycling, because RESCUE did not make any change to XPT, + ! and later the algorithm decided to call RESCUE again with the same data. This was fixed by + ! the skipping, and by terminating the algorithm if RESCUE is requested for two times + ! without any new function evaluations in between, which was the behavior of Powell's code. + ! Skipping an XNEW that is close but not identical to XPT(:, KPT) will cause discrepancy + ! between [BMAT, ZMAT] and XPT, since the former has been updated, but it is not severe as + ! the difference between XNEW and XPT(:, KPT) is tiny. + if (sum(abs(xnew - xpt(:, kpt))) <= 1.0E-2 * delta .or. .not. is_finite(sum(abs(xnew)))) then + cycle + end if + xpt(:, kpt) = xnew + + ! Calculate F at the new interpolation point, and set MODERR to the factor that is going to + ! multiply the KPT-th Lagrange function when the model is updated to provide interpolation + ! to the new function value. + x = xinbd(xbase, xpt(:, kpt), xl, xu, sl, su) ! In precise arithmetic, X = XBASE + XPT(:, KPT). + call evaluate(calfun, x, f) + nf = nf + 1_IK + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Rescue', iprint, nf, delta, f, x) + ! Save X, F into the history. + call savehist(nf, x, xhist, f, fhist) + + ! Update FVAL and KOPT. + fval(kpt) = f + if (f < fval(kopt)) then + kopt = kpt + end if + + ! Check whether to exit + subinfo = checkexit(maxfun, nf, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + + ! Set VQUAD to the value of the current model at the new XPT(:, KPT), which has at most two + ! nonzeros XP and XQ at the IP and IQ entries respectively. + vquad = fbase + if (ip > 0 .and. iq > 0) then + vquad = vquad + xp * (gopt(ip) + HALF * xp * hq(ip, ip)) + vquad = vquad + xq * (gopt(iq) + HALF * xq * hq(iq, iq)) + vquad = vquad + xp * xq * hq(ip, iq) + xxpt = xp * xpt(ip, :) + xq * xpt(iq, :) + elseif (ip > 0) then ! IP > 0, IQ == 0 + vquad = vquad + xp * (gopt(ip) + HALF * xp * hq(ip, ip)) + xxpt = xp * xpt(ip, :) + elseif (iq > 0) then ! IP == 0, IQ > 0 + vquad = vquad + xq * (gopt(iq) + HALF * xq * hq(iq, iq)) + xxpt = xq * xpt(iq, :) + end if + vquad = vquad + HALF * inprod(xxpt, pq * xxpt) + ! N.B.: INPROD(XXPT, PQ * XXPT) = INPROD(X, HESS_MUL(X, XPT, PQ)) + + ! Update the quadratic model. + moderr = f - vquad + gopt = gopt + moderr * bmat(:, kpt) + pqinc = moderr * matprod(zmat, zmat(kpt, :)) + pq(trueloc(ptsid <= 0)) = pq(trueloc(ptsid <= 0)) + pqinc(trueloc(ptsid <= 0)) + do k = 1, npt + if (ptsid(k) <= 0) then + cycle + end if + ip = floor(ptsid(k), kind(ip)) + iq = floor(real(n + 1, RP) * ptsid(k) - real((n + 1) * ip, RP), kind(iq)) + if (ip > 0 .and. iq > 0) then + hq(ip, ip) = hq(ip, ip) + pqinc(k) * ptsaux(1, ip)**2 + hq(iq, iq) = hq(iq, iq) + pqinc(k) * ptsaux(1, iq)**2 + hq(ip, iq) = hq(ip, iq) + pqinc(k) * ptsaux(1, ip) * ptsaux(1, iq) + hq(iq, ip) = hq(ip, iq) + elseif (ip > 0) then ! IP > 0, IQ == 0 + hq(ip, ip) = hq(ip, ip) + pqinc(k) * ptsaux(1, ip)**2 + elseif (iq > 0) then ! IP == 0, IP > 0 + hq(iq, iq) = hq(iq, iq) + pqinc(k) * ptsaux(2, iq)**2 + end if + end do + ptsid(kpt) = ZERO + end do +end if + +! Update GOPT if necessary. +if (kopt /= kbase) then + gopt = gopt + hess_mul(xpt(:, kopt), xpt, pq, hq) +end if + +!--------------------------------------------------------------------------------------------------! +! Zaikun 20221123: What if we rebuild the model? It seems to worsen the performance of BOBYQA. Why? +! !hq = ZERO +! !pq = omega_mul(1_IK, zmat, fval - fval(kopt)) +! !gopt = matprod(bmat(:, 1:npt), fval - fval(kopt)) + hess_mul(xpt(:, kopt), xpt, pq) +!--------------------------------------------------------------------------------------------------! + +!--------------------------------------------------------------------------------------------------! +! Zaikun 20221123: Shouldn't we correct the models using the new [BMAT, ZMAT]?! +! In this way, we do not even need the quadratic model received by RESCUE is an interpolant. +! !real(RP) :: qval(size(xpt, 2)) +! !qval = [(quadinc(xpt(:, k) - xpt(:, kopt), xpt, gopt, pq, hq), k=1, npt)] +! !pq = pq + omega_mul(1_IK, zmat, fval - qval - fval(kopt)) +! !gopt = gopt + matprod(bmat(:, 1:npt), fval - qval - fval(kopt)) + hess_mul(xpt(:, kopt), xpt, pq) +!--------------------------------------------------------------------------------------------------! + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN/+Inf', srname) + call assert(.not. any(fval < fval(kopt)), 'FVAL(KOPT) is the smallest in FVAL', srname) + call assert(size(sl) == n .and. size(su) == n, 'SIZE(SL) == N == SIZE(SU)', srname) + call assert(size(gopt) == n, 'SIZE(GOPT) == N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is n-by-n and symmetric', srname) + call assert(size(pq) == npt, 'SIZE(PQ) == NPT', srname) + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(all(xbase >= xl .and. xbase <= xu), 'XL <= XBASE <= XU', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + do k = 1, min(nf, maxxhist) + call assert(all(xhist(:, k) >= xl) .and. all(xhist(:, k) <= xu), 'XL <= XHIST <= XU', srname) + end do + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(all(xpt >= spread(sl, dim=2, ncopies=npt)) .and. & + & all(xpt <= spread(su, dim=2, ncopies=npt)), 'SL <= XPT <= SU', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT) == [N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1_IK, 'SIZE(ZMAT) == [NPT, NPT-N-1]', srname) + + do j = 1, npt + hcol(1:npt) = matprod(zmat, zmat(j, :)) + hcol(npt + 1:npt + n) = bmat(:, j) + call assert(precision(0.0_RP) < precision(0.0D0) .or. sum(abs(hcol)) > 0, 'Column '//num2str(j)//' of H is nonzero', srname) + end do +end if + +end subroutine rescue + + +subroutine updateh_rsc(knew, beta, vlag_in, bmat, zmat, info) +! !!! N.B.: UPDATEH_RSC is only used by RESCUE. +!--------------------------------------------------------------------------------------------------! +! This subroutine updates arrays BMAT and ZMAT in order to replace the interpolation point +! XPT(:, KNEW) by XNEW = XPT(:, KOPT) + D. See Section 4 of the BOBYQA paper. [BMAT, ZMAT] describes +! the matrix H in the BOBYQA paper (eq. 2.7), which is the inverse of the coefficient matrix of the +! KKT system for the least-Frobenius norm interpolation problem: ZMAT holds a factorization of the +! leading NPT*NPT submatrix OMEGA of H, the factorization being OMEGA = ZMAT*ZMAT^T; BMAT holds the +! last N ROWs of H except for the (NPT+1)th column. Note that the (NPT + 1)th row and (NPT + 1)th +! column of H are not stored as they are unnecessary for the calculation. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, DAMAGING_ROUNDING +use, non_intrinsic :: linalg_mod, only : planerot, matprod, outprod, symmetrize, issymmetric +use, non_intrinsic :: string_mod, only : num2str +implicit none + +! Inputs +integer(IK), intent(in) :: knew +real(RP), intent(in) :: beta +real(RP), intent(in) :: vlag_in(:) ! VLAG(NPT + N) + +! In-outputs +real(RP), intent(inout) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(inout) :: zmat(:, :) ! ZMAT(NPT, NPT-N-1) + +! Outputs +integer(IK), intent(out), optional :: info + +! Local variables +character(len=*), parameter :: srname = 'UPDATEH_RSC' +integer(IK) :: j +integer(IK) :: n +integer(IK) :: npt +real(RP) :: alpha +real(RP) :: denom +real(RP) :: grot(2, 2) +real(RP) :: hcol(size(bmat, 2)) +real(RP) :: sqrtdn +real(RP) :: tau +real(RP) :: v1(size(bmat, 1)) +real(RP) :: v2(size(bmat, 1)) +real(RP) :: vlag(size(vlag_in)) +real(RP) :: zknew1 + +! Sizes. +n = int(size(bmat, 1), kind(n)) +npt = int(size(bmat, 2) - size(bmat, 1), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(npt >= n + 2, 'NPT >= N+2', srname) + call assert(knew >= 1 .and. knew <= npt, '1 <= KNEW <= NPT', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1_IK, 'SIZE(ZMAT) == [NPT, NPT-N-1]', srname) + call assert(size(vlag_in) == npt + n, 'SIZE(VLAG) == NPT + N', srname) + + do j = 1, npt + hcol(1:npt) = matprod(zmat, zmat(j, :)) + hcol(npt + 1:npt + n) = bmat(:, j) + call assert(precision(0.0_RP) < precision(0.0D0) .or. sum(abs(hcol)) > 0, 'Column '//num2str(j)//' of H is nonzero', srname) + end do + + ! The following is too expensive to check. + !tol = 1.0E-2_RP + !call wassert(errh(bmat, zmat, xpt) <= tol .or. precision(0.0_RP) < precision(0.0D0), & + ! & 'H = W^{-1} in (2.7) of the BOBYQA paper', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (present(info)) then + info = INFO_DFT +end if + +! We must not do anything if KNEW is 0. This can only happen sometimes after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +! Read VLAG, and calculate parameters for the updating formula (4.9) and (4.14) of the BOBYQA paper. +vlag = vlag_in +tau = vlag(knew) +! In theory, DENOM can also be calculated after ZMAT is rotated below. However, this worsened the +! performance of BOBYQA in a test on 20220413. +denom = sum(zmat(knew, :)**2) * beta + tau**2 + +! Quite rarely, due to rounding errors, VLAG or BETA may not be finite, or DENOM may not be +! positive. In such cases, [BMAT, ZMAT] would be destroyed by the update, and hence we would rather +! not update them at all. Or should we simply terminate the algorithm? +if (.not. (is_finite(sum(abs(vlag)) + abs(beta)) .and. denom > 0)) then + if (present(info)) then + info = DAMAGING_ROUNDING + end if + return +end if + +! After the following line, VLAG = H*w - e_KNEW in the NEWUOA paper (where t = KNEW). +vlag(knew) = vlag(knew) - ONE + +! Apply Givens rotations to put zeros in the KNEW-th row of ZMAT. After this, ZMAT(KNEW, :) contains +! only one nonzero at ZMAT(KNEW, 1). Entries of ZMAT are treated as 0 if the moduli are quite small. +do j = 2, npt - n - 1_IK + if (abs(zmat(knew, j)) > 1.0E-20 * maxval(abs(zmat))) then ! This threshold is by Powell + grot = planerot(zmat(knew, [1_IK, j])) + zmat(:, [1_IK, j]) = matprod(zmat(:, [1_IK, j]), transpose(grot)) + end if + zmat(knew, j) = ZERO +end do + +! Put the KNEW-th column of the unupdated H (except for the (NPT+1)th entry) into HCOL. +hcol(1:npt) = zmat(knew, 1) * zmat(:, 1) +hcol(npt + 1:npt + n) = bmat(:, knew) + +! Complete the updating of ZMAT. See (4.14) of the BOBYQA paper. +sqrtdn = sqrt(denom) +zknew1 = zmat(knew, 1) / sqrtdn +zmat(:, 1) = (tau / sqrtdn) * zmat(:, 1) - zknew1 * vlag(1:npt) +zmat(knew, 1) = zknew1 ! Because TAU = VLAG(KNEW) + 1. Powell's code does not have this. + +! Finally, update the matrix BMAT. It implements the last N rows of (4.9) in the BOBYQA paper. +alpha = hcol(knew) +v1 = (alpha * vlag(npt + 1:npt + n) - tau * hcol(npt + 1:npt + n)) / denom +v2 = (-beta * hcol(npt + 1:npt + n) - tau * vlag(npt + 1:npt + n)) / denom +bmat = bmat + outprod(v1, vlag) + outprod(v2, hcol) !call r2update(bmat, ONE, v1, vlag, ONE, v2, hcol) +! N.B.: The use of OUTPROD is expensive memory-wise, but it is not our concern in this implementation. +! Numerically, the update above does not guarantee BMAT(:, NPT+1 : NPT+N) to be symmetric. +call symmetrize(bmat(:, npt + 1:npt + n)) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, 'SIZE(ZMAT) == [NPT, NPT-N-1]', srname) + + do j = 1, npt + hcol(1:npt) = matprod(zmat, zmat(j, :)) + hcol(npt + 1:npt + n) = bmat(:, j) + call assert(precision(0.0_RP) < precision(0.0D0) .or. sum(abs(hcol)) > 0, 'Column '//num2str(j)//' of H is nonzero', srname) + end do + + ! The following is too expensive to check. + ! !if (n * npt <= 50) then + ! ! xpt_test = xpt + ! ! xpt_test(:, knew) = xpt(:, kopt) + d + ! ! call assert(errh(bmat, zmat, xpt_test) <= tol .or. precision(0.0_RP) < precision(0.0D0), & + ! ! & 'H = W^{-1} in (2.7) of the BOBYQA paper', srname) + ! !end if +end if +end subroutine updateh_rsc + + +end module rescue_mod diff --git a/examples/fortran/prima/native/bobyqa/trustregion.f90 b/examples/fortran/prima/native/bobyqa/trustregion.f90 new file mode 100644 index 000000000..b5974eb4f --- /dev/null +++ b/examples/fortran/prima/native/bobyqa/trustregion.f90 @@ -0,0 +1,712 @@ +module trustregion_bobyqa_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning the trust-region calculations of BOBYQA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the BOBYQA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Thursday, April 04, 2024 PM09:26:23 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: trsbox, trrad + + +contains + + +subroutine trsbox(delta, gopt_in, hq_in, pq_in, sl, su, tol, xopt, xpt, crvmin, d) +!--------------------------------------------------------------------------------------------------! +! This subroutine approximately solves +! minimize Q(XOPT + D) subject to ||D|| <= DELTA, SL <= XOPT + D <= SU. +! See Section 3 of the BOBYQA paper. +! +! A version of the truncated conjugate gradient is applied. If a line search is restricted by +! a constraint, then the procedure is restarted, the values of the variables that are at their +! bounds being fixed. If the trust region boundary is reached, then further changes may be made to +! D, each one being in the two dimensional space that is spanned by the current D and the gradient +! of Q at XOPT+D, staying on the trust region boundary. Termination occurs when the reduction in +! Q seems to be close to the greatest reduction that can be achieved. +! +! CRVMIN is set to zero if D reaches the trust region boundary. Otherwise it is set to the least +! curvature of H that occurs in the conjugate gradient searches that are not restricted by any +! constraints. In Powell's BOBYQA code, a negative value (-1) is assigned to CRVMIN if all of +! the conjugate gradient searches are constrained. However, we set CRVMIN = 0 in this case, which +! makes no difference to the algorithm, because CRVMIN is only used to tell whether the recent +! models are sufficiently accurate, where both CRVMIN = 0 and CRVMIN < 0 provide a negative answer. +! +! XPT, XOPT, GOPT, HQ, PQ, SL and SU have the same meanings as the corresponding arguments of BOBYQB. +! DELTA is the trust region radius for the present calculation +! XNEW will be set to a new vector of variables that is approximately the one that minimizes the +! quadratic model within the trust region subject to the SL and SU constraints on the variables. +! It satisfies as equations the bounds that become active during the calculation. +! GNEW holds the gradient of the quadratic model at XOPT+D. It is updated when D is updated. +! XBDI is a working space vector. For I=1,2,...,N, the element XBDI(I) is set to -1.0, 0.0, or 1.0, +! the value being nonzero if and only if the I-th variable has become fixed at a bound, the bound +! being SL(I) or SU(I) in the case XBDI(I)=-1.0 or XBDI(I)=1.0, respectively. This information is +! accumulated during the construction of XNEW. +! The arrays S and HS hold the current search direction and the change in the gradient of Q along S. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, TEN, HALF, REALMIN, EPS, REALMAX, & + & DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : inprod, issymmetric, trueloc, norm +use, non_intrinsic :: powalg_mod, only : hess_mul +use, non_intrinsic :: univar_mod, only : interval_max + +implicit none + +! Inputs +real(RP), intent(in) :: delta +real(RP), intent(in) :: gopt_in(:) ! GOPT_IN(N) +real(RP), intent(in) :: hq_in(:, :) ! HQ_IN(N, N) +real(RP), intent(in) :: pq_in(:) ! PQ_IN(NPT) +real(RP), intent(in) :: sl(:) ! SL(N) +real(RP), intent(in) :: su(:) ! SU(N) +real(RP), intent(in) :: tol +real(RP), intent(in) :: xopt(:) ! XOPT(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +real(RP), intent(out) :: crvmin +real(RP), intent(out) :: d(:) ! D(N) + +! Local variables +character(len=*), parameter :: srname = 'TRSBOX' +integer(IK) :: iact +integer(IK) :: n +integer(IK) :: npt +integer(IK) :: xbdi(size(gopt_in)) +integer(IK) :: grid_size +integer(IK) :: iter +integer(IK) :: itercg +integer(IK) :: maxiter +integer(IK) :: nact +integer(IK) :: nactsav +logical :: scaled +logical :: twod_search +real(RP) :: beta +real(RP) :: bstep +real(RP) :: cth +real(RP) :: delsq +real(RP) :: dhd +real(RP) :: dhs +real(RP) :: dold(size(d)) +real(RP) :: dredg +real(RP) :: dredsq +real(RP) :: ds +real(RP) :: ggsav +real(RP) :: gredsq +real(RP) :: hangt +real(RP) :: hangt_bd +real(RP) :: hq(size(hq_in, 1), size(hq_in, 2)) +real(RP) :: pq(size(pq_in)) +real(RP) :: qred +real(RP) :: rayleighq +real(RP) :: resid +real(RP) :: sbound(size(gopt_in)) +real(RP) :: sdec +real(RP) :: shs +real(RP) :: sqrtd +real(RP) :: sredg +real(RP) :: stepsq +real(RP) :: sth +real(RP) :: stplen +real(RP) :: temp +real(RP) :: xtest(size(xopt)) +real(RP) :: args(5) +real(RP) :: dred(size(gopt_in)) +real(RP) :: gnew(size(gopt_in)) +real(RP) :: gopt(size(gopt_in)) +real(RP) :: hdred(size(gopt_in)) +real(RP) :: hs(size(gopt_in)) +real(RP) :: modscal +real(RP) :: s(size(gopt_in)) +real(RP) :: sqdscr(size(gopt_in)) +real(RP) :: ssq(size(gopt_in)) +real(RP) :: tanbd(size(gopt_in)) +real(RP) :: xnew(size(gopt_in)) + +! Sizes +n = int(size(gopt_in), kind(n)) +npt = int(size(pq_in), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(delta > 0, 'DELTA > 0', srname) + call assert(size(hq_in, 1) == n .and. issymmetric(hq_in), 'HQ is n-by-n and symmetric', srname) + call assert(size(pq_in) == npt, 'SIZE(PQ) == NPT', srname) + call assert(size(sl) == n .and. all(sl <= 0), 'SIZE(SL) == N, SL <= 0', srname) + call assert(size(su) == n .and. all(su >= 0), 'SIZE(SU) == N, SU >= 0', srname) + call assert(size(xopt) == n .and. all(is_finite(xopt)), 'SIZE(XOPT) == N, XOPT is finite', srname) + call assert(all(xopt >= sl .and. xopt <= su), 'SL <= XOPT <= SU', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(all(xpt >= spread(sl, dim=2, ncopies=npt)) .and. & + & all(xpt <= spread(su, dim=2, ncopies=npt)), 'SL <= XPT <= SU', srname) + call assert(size(d) == n, 'SIZE(D) == N', srname) + call assert(size(gnew) == n, 'SIZE(GNEW) == N', srname) + call assert(size(xnew) == n, 'SIZE(XNEW) == N', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Scale the problem if GOPT contains large values. Otherwise, floating point exceptions may occur. +! Note that CRVMIN must be scaled back if it is nonzero, but step is scale invariant. +! N.B.: It is faster and safer to scale by multiplying a reciprocal than by division. See +! https://fortran-lang.discourse.group/t/ifort-ifort-2021-8-0-1-0e-37-1-0e-38-0/ +if (maxval(abs(gopt_in)) > 1.0E12) then ! The threshold is empirical. + modscal = max(TWO * REALMIN, ONE / maxval(abs(gopt_in))) ! MAX: precaution against underflow. + gopt = gopt_in * modscal + pq = pq_in * modscal + hq = hq_in * modscal + scaled = .true. +else + modscal = ONE ! This value is not used, but Fortran compilers may complain without it. + gopt = gopt_in + pq = pq_in + hq = hq_in + scaled = .false. +end if + +! The initial values of IACT, DREDSQ, and GGSAV are unused but to entertain Fortran compilers. +! TODO: Check that GGSAV has been initialized before used. +iact = 0 +dredsq = ZERO +ggsav = ZERO + +! The sign of GOPT(I) gives the sign of the change to the I-th variable that will reduce Q from its +! value at XOPT. Thus XBDI(I) shows whether or not to fix the I-th variable at one of its bounds +! initially, with NACT being set to the number of fixed variables. +xbdi = 0 +xbdi(trueloc(xopt >= su .and. gopt <= 0)) = 1 +xbdi(trueloc(xopt <= sl .and. gopt >= 0)) = -1 +nact = int(count(xbdi /= 0), kind(nact)) + +! Initialized D and CRVMIN. +d = ZERO +crvmin = -REALMAX + +! GNEW is the gradient at the current iterate. +gnew = gopt +gredsq = sum(gnew(trueloc(xbdi == 0))**2) +! DELSQ is the upper bound on the sum of squares of the free variables. +delsq = delta * delta +! QRED is the reduction in Q so far. +qred = ZERO +! BETA is the coefficient for the previous searching direction in the conjugate gradient method. +beta = ZERO + +! ITERCG is the number of CG iterations corresponding to the current set of active bounds. +itercg = 0 + +! TWOD_SEARCH: whether to perform a 2-dimensional search after the truncated CG method. +twod_search = .false. ! The default value of TWOD_SEARCH is FALSE! + +! Powell's code is essentially a DO WHILE loop. We impose an explicit MAXITER. +! The formulation of MAXITER below contains a precaution against overflow. In MATLAB/Python/Julia/R, +! we can write maxiter = min(10000, (n - nact)^2). +! Powell commented in the BOBYQA paper (the paragraph above (3.7)) that "numerical experiments show +! that it is very unusual for subroutine TRSBOX to make more than ten changes to d when seeking an +! approximate solution to the subproblem (1.8), even if there are hundreds of variables." +maxiter = int(min(10**min(4, range(0_IK)), int(n - nact)**2), IK) +do iter = 1, maxiter + resid = delsq - sum(d(trueloc(xbdi == 0))**2) + if (resid <= 0) then + twod_search = .true. + exit + end if + + ! Set the next search direction of the conjugate gradient method. It is the steepest descent + ! direction initially and when the iterations are restarted because a variable has just been + ! fixed by a bound, and of course the components of the fixed variables are zero. MAXITER is an + ! upper bound on the indices of the conjugate gradient iterations. + if (itercg == 0) then + ! TODO: If we are sure that S contain only finite values, we may merge this case into the next. + s = -gnew + else + s = beta * s - gnew + end if + s(trueloc(xbdi /= 0)) = ZERO + stepsq = sum(s**2) + ds = inprod(d(trueloc(xbdi == 0)), s(trueloc(xbdi == 0))) + + if (.not. (stepsq > EPS * delsq .and. gredsq * delsq > (tol * qred)**2 .and. .not. is_nan(ds))) then + exit + end if + + ! Set BSTEP to the length of the step to the trust region boundary and STPLEN to the steplength, + ! ignoring the simple bounds. + + ! SQRTD: square root of a discriminant. The MAXVAL avoids SQRTD < ABS(DS) due to underflow. + sqrtd = maxval([sqrt(stepsq * resid + ds * ds), sqrt(stepsq * resid), abs(ds)]) + + ! Zaikun 20220210: For the IF ... ELSE ... END IF below, Powell's condition for the IF is DS>=0. + ! In theory, switching the condition to DS > 0 changes nothing; indeed, the two formulations + ! of BSTEP are equivalent. However, surprisingly, DS > 0 clearly worsens the performance of + ! BOBYQA in tests on 20220210, 20221206. Why? When DS = 0, what should be the best formulation? + ! What if we are at the first iteration? BSTEP = DELTA/||D||? + ! See TRSAPP.F90 of NEWUOA. + !if (ds > 0) then ! Zaikun 20210925 + if (ds >= 0) then + bstep = resid / (sqrtd + ds) + else + bstep = (sqrtd - ds) / stepsq + end if + ! BSTEP < 0 should not happen. BSTEP can be 0 or NaN when, e.g., DS or STEPSQ becomes Inf. + ! Powell's code does not handle this. + if (bstep <= 0 .or. .not. is_finite(bstep)) then + exit + end if + + hs = hess_mul(s, xpt, pq, hq) + shs = inprod(s(trueloc(xbdi == 0)), hs(trueloc(xbdi == 0))) + stplen = bstep + if (shs > 0) then + stplen = min(bstep, gredsq / shs) + end if + + ! Reduce STPLEN if necessary in order to preserve the simple bounds, letting IACT be the index + ! of the new constrained variable. + ! N.B. (Zaikun 20220422): + ! Theory and computation differ considerably in the calculation of STPLEN and IACT. + ! 1. Theoretically, the WHERE constructs can simplify (S > 0 .and. XTEST > SU) to (S > 0) and + ! (S < 0, XTEST < SL) to (S < 0), which will be equivalent to Powell's original code. However, + ! overflow will occur due to huge values in SU or SL that indicate the absence of bounds, and + ! Fortran compilers will complain. It is not an issue in MATLAB/Python/Julia/R. + ! 2. Theoretically, we can also simplify (S > 0 .and. XTEST > SU) to (XTEST > SU). This is + ! because the algorithm intends to ensure that SL <= XSUM <= SU, under which the inequality + ! XTEST(I) > SU(I) implies S(I) > 0. Numerically, however, XSUM may violate the bounds slightly + ! due to rounding. If we replace (S > 0 .and. XTEST > SU) with (XTEST > SU), then SBOUND(I) will + ! be -Inf when SU(I) - XSUM(I) is negative (although tiny) and S(I) is +0 (positively signed + ! zero), which will lead to STPLEN = -Inf and IACT = I > 0. This will trigger a restart of the + ! conjugate gradient method with DELSQ updated to DELSQ - D(IACT)**2; if D(IACT)**2 << DELSQ, + ! then DELSQ can remain unchanged due to rounding, leading to an infinite cycling. + ! 3. Theoretically, the WHERE construct corresponding to S > 0 can calculate SBOUND by + ! MIN(STPLEN * S, SU - XSUM) / S instead of (SU - XSUM) / S, since this quotient matters only if + ! it is less than STPLEN. The motivation is to avoid overflow even without checking XTEST > XU. + ! Yet such an implementation clearly worsens the performance of BOBYQA in our test on 20220422. + ! Why? Note that the conjugate gradient method restarts when IACT > 0. Due to rounding errors, + ! MIN(STPLEN * S, SU - XSUM) / S can frequently contain entries less than STPLEN, leading to a + ! positive IACT and hence a restart. This turns out harmful to the performance of the algorithm, + ! but WHY? It can be rectified in two ways: use MIN(STPLEN, (SU-XSUM) / S) instead of + ! MIN(STPLEN*S, SU-XSUM)/S, or set IACT to a positive value only if the minimum of SBOUND is + ! surely less STPLEN, e.g. ANY(SBOUND < (ONE-EPS) * STPLEN). The first method does not avoid + ! overflow and makes little sense. + xnew = xopt + d + xtest = xnew + stplen * s + sbound = stplen + where (s > 0 .and. xtest > su) sbound = (su - xnew) / s + where (s < 0 .and. xtest < sl) sbound = (sl - xnew) / s + !!MATLAB: + !!sbound(s > 0) = (su(s > 0) - xnew(s > 0)) / s(s > 0); + !!sbound(s < 0) = (sl(s < 0) - xnew(s < 0)) / s(s < 0); + !----------------------------------------------------------------------------------------------! + ! The code below is mathematically equivalent to the above but numerically inferior as explained. + !where (s > 0) sbound = min(stplen * s, su - xnew) / s + !where (s < 0) sbound = max(stplen * s, sl - xnew) / s + !----------------------------------------------------------------------------------------------! + sbound(trueloc(is_nan(sbound))) = stplen ! Needed? No if we are sure that D and S are finite. + iact = 0 + if (any(sbound < stplen)) then + iact = int(minloc(sbound, dim=1), kind(iact)) + stplen = sbound(iact) + !!MATLAB: [stplen, iact] = min(sbound); + end if + !----------------------------------------------------------------------------------------------! + ! Alternatively, IACT and STPLEN can be calculated as below. + ! !IACT = INT(MINLOC([STPLEN, SBOUND], DIM=1), KIND(IACT)) - 1_IK + ! !STPLEN = MINVAL([STPLEN, SBOUND]) ! This line cannot be exchanged with the last + ! We prefer our implementation, as the code is more explicit; in addition, it is more flexible: + ! we can change the condition ANY(SBOUND < STPLEN) to ANY(SBOUND < (1 - EPS) * STPLEN) or + ! ANY(SBOUND < (1 + EPS) * STPLEN), depending on whether we believe a false positive or a false + ! negative of IACT > 0 is more harmful --- according to our test on 20220422, it is the former, + ! as mentioned above. + !----------------------------------------------------------------------------------------------! + + ! Update CRVMIN, GNEW, and D. Set SDEC to the decrease that occurs in Q. + sdec = ZERO + if (stplen > 0) then + itercg = itercg + 1_IK + rayleighq = shs / stepsq + if (iact == 0 .and. rayleighq > 0) then + if (crvmin <= -REALMAX) then ! CRVMIN <= -REALMAX means CRVMIN has not been set. + crvmin = rayleighq + else + crvmin = min(crvmin, rayleighq) + end if + end if + ggsav = gredsq + gnew = gnew + stplen * hs + gredsq = sum(gnew(trueloc(xbdi == 0))**2) + dold = d + d = d + stplen * s + + ! Exit in case of Inf/NaN in D. + if (.not. is_finite(sum(abs(d)))) then + d = dold + exit + end if + + sdec = max(stplen * (ggsav - HALF * stplen * shs), ZERO) + qred = qred + sdec + end if + + ! Restart the conjugate gradient method if it has hit a new bound. + if (iact > 0) then + nact = nact + 1_IK + call assert(abs(s(iact)) > 0, 'S(IACT) /= 0', srname) + xbdi(iact) = nint(sign(ONE, s(iact)), kind(xbdi)) !!MATLAB: xbdi(iact) = sign(s(iact)) + ! Exit when NACT = N (NACT > N is impossible). We must update XBDI before exiting! + if (nact >= n) then + exit ! This leads to a difference. Why? + end if + delsq = delsq - d(iact)**2 + if (delsq <= 0) then + twod_search = .true. + ! Why set TWOD_SEARCH to TRUE? Because DELSQ <= 0 just means that D reaches the trust + ! region boundary. + exit + end if + beta = ZERO + itercg = 0 + gredsq = sum(gnew(trueloc(xbdi == 0))**2) + elseif (stplen < bstep) then + ! Either apply another conjugate gradient iteration or exit. + ! N.B. ITERCG > N - NACT is impossible. + if (itercg >= n - nact .or. sdec <= tol * qred .or. is_nan(sdec) .or. is_nan(qred)) then + exit + end if + beta = gredsq / ggsav ! Has GGSAV got the correct value yet? + else + twod_search = .true. + exit + end if +end do + +! Set MAXITER for the 2-dimensional search on the trust region boundary. Powell's code essentially +! sets MAXITER to infinity; the loop exits when NACT >= N-1 or the procedure cannot significantly +! reduce the quadratic model. We set a finite but large MAXITER as a safeguard. +if (twod_search) then + crvmin = ZERO + maxiter = 10_IK * (n - nact) +else + maxiter = 0 +end if + +! Improve D by a sequential 2-dimensional search on the boundary of the trust region for the +! variables that have not reached a bound. See (3.6) of the BOBYQA paper and the elaborations nearby. +! 1. At each iteration, the current D is improved by a search conducted on the circular arch +! {D(THETA): D(THETA) = (I-P)*D + [COS(THETA)*P*D + SIN(THETA)*S], 0<=THETA<=PI/2, SL<=XOPT+D(THETA)<=SU}, +! where P is the orthogonal projection onto the space of the variables that have not reached their +! bounds, and S is a linear combination of P*D and P*G(XOPT+D) with ||S|| = ||P*D|| and G(.) being +! the gradient of the quadratic model. The iteration is performed only if P*D and P*G(XOPT+D) are +! not nearly parallel. The arc lies in the hyperplane (I-P)*D + Span{P*D, P*G(XOPT+D)} and the trust +! region boundary {D: ||D||=DELTA}; it is part of the circle (I-P)*D + {COS(THETA)*P*D + SIN(THETA)*S} +! with THETA being in [0, PI/2] and restricted by the bounds on X. +! 2. In (3.6) of the BOBYQA paper, Powell wrote that 0 <= THETA <= PI/4, which seems a typo. +! 3. The search on the arch is done by calling INTERVAL_MAX, which maximizes INTERVAL_FUN_TRSBOX. +! INTERVAL_FUN_TRSBOX is essentially Q(XOPT + D) - Q(XOPT + D(THETA)), but its independent variable +! is not THETA but TAN(THETA/2), namely "tangent of the half angle" in Powell's code/comments. This +! "half" may be the reason for the apparent typo mentioned above. +! Question (Zaikun 20220424): Shouldn't we try something similar in GEOSTEP? + +nactsav = nact - 1_IK +do iter = 1, maxiter + xnew = xopt + d + + ! Update XBDI. It indicates whether the lower (-1) or upper bound (+1) is reached or not (0). + xbdi(trueloc(xbdi == 0 .and. (xnew >= su))) = 1 + xbdi(trueloc(xbdi == 0 .and. (xnew <= sl))) = -1 + nact = int(count(xbdi /= 0), kind(nact)) + if (nact >= n - 1) then + exit + end if + + ! Update GREDSQ, DREDG, DREDSQ. + gredsq = sum(gnew(trueloc(xbdi == 0))**2) + dredg = inprod(d(trueloc(xbdi == 0)), gnew(trueloc(xbdi == 0))) + if (iter == 1 .or. nact > nactsav) then + dredsq = sum(d(trueloc(xbdi == 0))**2) ! In theory, DREDSQ changes only when NACT increases. + dred = d + dred(trueloc(xbdi /= 0)) = ZERO + hdred = hess_mul(dred, xpt, pq, hq) + nactsav = nact + end if + + ! Let the search direction S be a linear combination of the reduced D and the reduced G that is + ! orthogonal to the reduced D. + temp = gredsq * dredsq - dredg * dredg + if (.not. temp > tol**2 * max(gredsq * dredsq, qred**2)) then ! TEMP is tiny or NaN occurs + exit + end if + temp = sqrt(temp) + s = (dredg * d - dredsq * gnew) / temp + s(trueloc(xbdi /= 0)) = ZERO + sredg = -temp + + ! By considering the simple bounds on the free variables, calculate an upper bound on the + ! TANGENT of HALF the angle of the alternative iteration, namely ANGBD. The bounds are + ! SL - XOPT <= COS(THETA)*D + SIN(THETA)*S <= SU - XOPT for the free variables. + ! Defining HANGT = TAN(THETA/2), and using the tangent half-angle formula, we have + ! (1+HANGT^2)*(SL - XOPT) <= (1-HANGT^2)*D + 2*HANGT*S <= (1+HANGT^2)*(SU - XOPT), + ! which is required for all free variables. The indices of the free variable are those with + ! XBDI == 0. Solving this inequality system for HANGT in [0, PI/4], we get bounds for HANGT, + ! namely TANBD; the final bound for HANGT is the minimum of TANBD, which is HANGT_BD. + ! When solving the system, note that SL < XOPT < SU and SL < XOPT + D < SU if XBDI = 0. + ! + ! Note the following for the calculation of the first SQDSCR below (the second is similar). + ! 0. SQDSCR means "square root of discriminant". + ! 1. When calculating the first SQDSCR, Powell's code checks whether SSQ - (XOPT - SL)**2) is + ! positive. However, overflow will occur if SL contains large values that indicate absence of + ! bounds. It is not a problem in MATLAB/Python/Julia/R. + ! 2. Even if XOPT - SL < SQRT(SSQ), rounding errors may render SSQ - (XOPT - SL)**2) < 0. + ssq = d**2 + s**2 ! Indeed, only SSQ(TRUELOC(XBDI == 0)) is needed. + tanbd = ONE + sqdscr = -REALMAX + where (xbdi == 0 .and. xopt - sl < sqrt(ssq)) sqdscr = sqrt(max(ZERO, ssq - (xopt - sl)**2)) + where (sqdscr - s > 0) tanbd = min(tanbd, (xnew - sl) / (sqdscr - s)) + sqdscr = -REALMAX + where (xbdi == 0 .and. su - xopt < sqrt(ssq)) sqdscr = sqrt(max(ZERO, ssq - (su - xopt)**2)) + where (sqdscr + s > 0) tanbd = min(tanbd, (su - xnew) / (sqdscr + s)) + tanbd(trueloc(is_nan(tanbd))) = ZERO + !----------------------------------------------------------------------------------------------! + !!MATLAB code for defining TANBD: + !!xfree = (xbdi == 0); + !!ssq = NaN(n, 1); + !!ssq(xfree) = s(xfree).^2 + d(xfree).^2; + !!discmn = NaN(n, 1); + !!discmn(xfree) = ssq(xfree) - (xopt(xfree) - sl(xfree))**2; % This is a discriminant. + !!tanbd = 1; + !!mask = (xfree & discmn > 0 & sqrt(discmn) - s > 0); + !!tanbd(mask) = min(tanbd(mask), (xnew(mask) - sl(mask)) / (sqrt(discmn(mask)) - s(mask))); + !!discmn(xfree) = ssq(xfree) - (su(xfree) - xopt(xfree))**2; % This is a discriminant. + !!mask = (xfree & discmn > 0 & sqrt(discmn) + s > 0); + !!tanbd(mask) = min(tanbd(mask), (su(mask) - xnew(mask)) / (sqrt(discmn(mask)) + s(mask))); + !!tanbd(isnan(tanbd)) = 0; + !----------------------------------------------------------------------------------------------! + + iact = 0 + hangt_bd = ONE + if (any(tanbd < 1)) then + iact = int(minloc(tanbd, dim=1), kind(iact)) + hangt_bd = tanbd(iact) + !!MATLAB: [hangt_bd, iact] = min(tanbd); + end if + if (hangt_bd <= 0) then + exit + end if + + ! Calculate HS and some curvatures for the alternative iteration. + hs = hess_mul(s, xpt, pq, hq) + shs = inprod(s(trueloc(xbdi == 0)), hs(trueloc(xbdi == 0))) + dhs = inprod(d(trueloc(xbdi == 0)), hs(trueloc(xbdi == 0))) + dhd = inprod(d(trueloc(xbdi == 0)), hdred(trueloc(xbdi == 0))) + + ! Seek the greatest reduction in Q for a range of equally spaced values of HANGT in [0, ANGBD], + ! with HANGT being the TANGENT of HALF the angle of the alternative iteration. + args = [shs, dhd, dhs, dredg, sredg] + if (any(is_nan(args))) then + exit + end if + ! Define the grid size of the search for HANGT. Powell defined the size to be 4 if hangt_bd is + ! nearly zero and 20 if it is nearly one, with a linear interpolation in between. We double this + ! size, which improves the performance of BOBYQA in general according to a test on 20230827. + !grid_size = nint(17.0_RP * hangt_bd + 4.1_RP, kind(grid_size)) ! Powell's version + grid_size = 2_IK * nint(17.0_RP * hangt_bd + 4.1_RP, kind(grid_size)) + !!MATLAB: grid_size = 2 * round(17 * hangt_bd + 4.1_RP) + hangt = interval_max(interval_fun_trsbox, ZERO, hangt_bd, args, grid_size) + sdec = interval_fun_trsbox(hangt, args) + if (.not. sdec > 0) then + exit + end if + + ! Update GNEW, D and HDRED. If the angle of the alternative iteration is restricted by a bound + ! on a free variable, that variable is fixed at the bound. The MIN below is a precaution against + ! rounding errors. + cth = min((ONE - hangt**2) / (ONE + hangt**2), ONE - hangt**2) + sth = min((hangt + hangt) / (ONE + hangt**2), hangt + hangt) + gnew = gnew + (cth - ONE) * hdred + sth * hs + dold = d + d(trueloc(xbdi == 0)) = cth * d(trueloc(xbdi == 0)) + sth * s(trueloc(xbdi == 0)) + + ! Exit in case of Inf/NaN in D. + if (.not. is_finite(sum(abs(d)))) then + d = dold + exit + end if + + hdred = cth * hdred + sth * hs + qred = qred + sdec + if (iact >= 1 .and. iact <= n .and. hangt >= hangt_bd) then ! D(IACT) reaches lower/upper bound. + xbdi(iact) = nint(sign(ONE, xopt(iact) + d(iact) - HALF * (sl(iact) + su(iact))), kind(xbdi)) + !!MATLAB: xbdi(iact) = sign(xopt(iact)+d(iact) - 0.5*(sl+su)); + elseif (.not. sdec > tol * qred) then ! SDEC is small or NaN occurs + exit + end if +end do + +! Set D, giving careful attention to the bounds. +xnew = max(sl, min(su, xopt + d)) +xnew(trueloc(xbdi == -1)) = sl(trueloc(xbdi == -1)) +xnew(trueloc(xbdi == 1)) = su(trueloc(xbdi == 1)) +d = xnew - xopt + +! Set CRVMIN to ZERO if it has never been set or becomes NaN due to ill conditioning. +if (crvmin <= -REALMAX .or. is_nan(crvmin)) then + crvmin = ZERO +end if + +! Scale CRVMIN back before return. Note that the trust-region step is scale invariant. +if (scaled .and. crvmin > 0) then + crvmin = crvmin / modscal +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + ! Due to rounding, it may happen that ||D|| > DELTA, but ||D|| > 2*DELTA is highly improbable. + call assert(norm(d) <= TWO * delta, '||D|| <= 2*DELTA', srname) + call assert(crvmin >= 0, 'CRVMIN >= 0', srname) + ! D is supposed to satisfy the bound constraints SL <= XOPT + D <= SU. + call assert(all(xopt + d >= sl - TEN * EPS * max(ONE, abs(sl)) .and. & + & xopt + d <= su + TEN * EPS * max(ONE, abs(su))), 'SL <= XOPT + D <= SU', srname) +end if + +end subroutine trsbox + + +function interval_fun_trsbox(hangt, args) result(f) +!--------------------------------------------------------------------------------------------------! +! This function defines the objective function of the search for HANGT in TRSBOX, with HANGT being +! the TANGENT of HALF the angle of the "alternative iteration". +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ZERO, ONE, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: hangt +real(RP), intent(in) :: args(:) + +! Outputs +real(RP) :: f + +! Local variables +character(len=*), parameter :: srname = 'INTERVAL_FUN_TRSBOX' +real(RP) :: sth + +! Preconditions +if (DEBUGGING) then + call assert(size(args) == 5, 'SIZE(ARGS) == 5', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +f = ZERO +if (abs(hangt) > 0) then + sth = (hangt + hangt) / (ONE + hangt * hangt) + f = args(1) + hangt * (hangt * args(2) - args(3) - args(3)) + f = sth * (hangt * args(4) - args(5) - HALF * sth * f) + ! N.B.: ARGS = [SHS, DHD, DHS, DREDG, SREDG] +end if + +!====================! +! Calculation ends ! +!====================! +end function interval_fun_trsbox + + +function trrad(delta_in, dnorm, eta1, eta2, gamma1, gamma2, ratio) result(delta) +!--------------------------------------------------------------------------------------------------! +! This function updates the trust region radius according to RATIO and DNORM. +!--------------------------------------------------------------------------------------------------! + +! Generic module +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan +use, non_intrinsic :: debug_mod, only : assert + +implicit none + +! Input +real(RP), intent(in) :: delta_in ! Current trust-region radius +real(RP), intent(in) :: dnorm ! Norm of current trust-region step +real(RP), intent(in) :: eta1 ! Ratio threshold for contraction +real(RP), intent(in) :: eta2 ! Ratio threshold for expansion +real(RP), intent(in) :: gamma1 ! Contraction factor +real(RP), intent(in) :: gamma2 ! Expansion factor +real(RP), intent(in) :: ratio ! Reduction ratio + +! Outputs +real(RP) :: delta + +! Local variables +character(len=*), parameter :: srname = 'TRRAD' + +! Preconditions +if (DEBUGGING) then + call assert(delta_in >= dnorm .and. dnorm > 0, 'DELTA_IN >= DNORM > 0', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + ! By the definition of RATIO in ratio.f90, RATIO cannot be NaN unless the actual reduction is + ! NaN, which should NOT happen due to the moderated extreme barrier. + call assert(.not. is_nan(ratio), 'RATIO is not NaN', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (ratio <= eta1) then + delta = min(gamma1 * delta_in, dnorm) ! Powell's BOBYQA. + !delta = gamma1 * dnorm ! Powell's UOBYQA/NEWUOA. + !delta = gamma1 * delta_in ! Powell's COBYLA/LINCOA. Works poorly here. +elseif (ratio <= eta2) then + delta = max(gamma1 * delta_in, dnorm) ! Powell's UOBYQA/NEWUOA/BOBYQA/LINCOA +else + delta = max(gamma1 * delta_in, gamma2 * dnorm) ! Powell's NEWUOA/BOBYQA. + !delta = max(delta_in, gamma2 * dnorm) ! Modified version. Works well for UOBYQA. + !delta = max(delta_in, 1.25_RP * dnorm, dnorm + rho) ! Powell's UOBYQA + !delta = min(max(gamma1 * delta_in, gamma2 * dnorm), sqrt(gamma2) * delta_in) ! Powell's LINCOA. +end if + +! For noisy problems, the following may work better. +! !if (ratio <= eta1) then +! ! delta = gamma1 * dnorm +! !elseif (ratio <= eta2) then ! Ensure DELTA >= DELTA_IN +! ! delta = delta_in +! !else ! Ensure DELTA > DELTA_IN with a constant factor +! ! delta = max(delta_in * (1.0_RP + gamma2) / 2.0_RP, gamma2 * dnorm) +! !end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(delta > 0, 'DELTA > 0', srname) +end if + +end function trrad + + +end module trustregion_bobyqa_mod diff --git a/examples/fortran/prima/native/bobyqa/update.f90 b/examples/fortran/prima/native/bobyqa/update.f90 new file mode 100644 index 000000000..7e49fec3f --- /dev/null +++ b/examples/fortran/prima/native/bobyqa/update.f90 @@ -0,0 +1,502 @@ +module update_bobyqa_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning the updates when XPT(:, KNEW) becomes XNEW = XOPT + D. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the BOBYQA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Thu 14 Aug 2025 07:34:12 AM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: updateh, updatexf, updateq, tryqalt + + +contains + + +subroutine updateh(knew, kopt, d, xpt, bmat, zmat, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates arrays BMAT and ZMAT in order to replace the interpolation point +! XPT(:, KNEW) by XNEW = XPT(:, KOPT) + D. See Section 4 of the BOBYQA paper. [BMAT, ZMAT] describes +! the matrix H in the BOBYQA paper (eq. 2.7), which is the inverse of the coefficient matrix of the +! KKT system for the least-Frobenius norm interpolation problem: ZMAT holds a factorization of the +! leading NPT*NPT submatrix OMEGA of H, the factorization being OMEGA = ZMAT*ZMAT^T; BMAT holds the +! last N ROWs of H except for the (NPT+1)th column. Note that the (NPT + 1)th row and (NPT + 1)th +! column of H are not stored as they are unnecessary for the calculation. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, DAMAGING_ROUNDING +use, non_intrinsic :: linalg_mod, only : planerot, matprod, outprod, symmetrize, issymmetric +use, non_intrinsic :: powalg_mod, only : calbeta, calvlag +use, non_intrinsic :: string_mod, only : num2str + +implicit none + +! Inputs +integer(IK), intent(in) :: knew +integer(IK), intent(in) :: kopt +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! In-outputs +real(RP), intent(inout) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(inout) :: zmat(:, :) ! ZMAT(NPT, NPT-N-1) + +! Outputs +integer(IK), intent(out), optional :: info + +! Local variables +character(len=*), parameter :: srname = 'UPDATEH' +integer(IK) :: j +integer(IK) :: n +integer(IK) :: npt +real(RP) :: alpha +real(RP) :: beta +real(RP) :: denom +real(RP) :: grot(2, 2) +real(RP) :: hcol(size(bmat, 2)) +real(RP) :: sqrtdn +real(RP) :: tau +real(RP) :: v1(size(bmat, 1)) +real(RP) :: v2(size(bmat, 1)) +real(RP) :: vlag(size(bmat, 2)) + +! Sizes. +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(npt >= n + 2, 'NPT >= N+2', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1_IK, & + & 'SIZE(ZMAT) == [NPT, NPT-N-1]', srname) + + do j = 1, npt + hcol(1:npt) = matprod(zmat, zmat(j, :)) + hcol(npt + 1:npt + n) = bmat(:, j) + call assert(precision(0.0_RP) < precision(0.0D0) .or. sum(abs(hcol)) > 0, 'Column '//num2str(j)//' of H is nonzero', srname) + end do + + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + + ! The following is too expensive to check. + !tol = 1.0E-2_RP + !call wassert(errh(bmat, zmat, xpt) <= tol .or. precision(0.0_RP) < precision(0.0D0), & + ! & 'H = W^{-1} in (2.7) of the BOBYQA paper', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (present(info)) then + info = INFO_DFT +end if + +! Do anything if KNEW is 0. This can only happen sometimes after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +! Put the KNEW-th column of the unupdated H (except for the (NPT+1)th entry) into HCOL. Powell's +! code does this after ZMAT is rotated below, and then HCOL(1:NPT) = ZMAT(KNEW, 1) * ZMAT(:, 1), +! which saves flops but also introduces rounding errors due to the rotation. +hcol(1:npt) = matprod(zmat, zmat(knew, :)) +hcol(npt + 1:npt + n) = bmat(:, knew) + +! Calculate VLAG and BETA and other parameters for (4.9) and (4.14) of the BOBYQA paper. +beta = calbeta(kopt, bmat, d, xpt, zmat) +vlag = calvlag(kopt, bmat, d, xpt, zmat) + +! In theory, DENOM can also be calculated after ZMAT is rotated below. However, this worsened the +! performance of BOBYQA in a test on 20220413. +alpha = hcol(knew) +tau = vlag(knew) +denom = alpha * beta + tau**2 + +! After the following line, VLAG = H*w - e_KNEW in the NEWUOA paper (where t = KNEW). +vlag(knew) = vlag(knew) - ONE + +! Quite rarely, due to rounding errors, VLAG or BETA may not be finite, or DENOM may not be +! positive. In such cases, [BMAT, ZMAT] would be destroyed by the update, and hence we would rather +! not update them at all. Or should we simply terminate the algorithm? +if (.not. (is_finite(sum(abs(hcol)) + sum(abs(vlag)) + abs(beta)) .and. denom > 0)) then + if (present(info)) then + info = DAMAGING_ROUNDING + end if + return +end if + +! Update the matrix BMAT. It implements the last N rows of (4.9) in the BOBYQA paper. +v1 = (alpha * vlag(npt + 1:npt + n) - tau * hcol(npt + 1:npt + n)) / denom +v2 = (-beta * hcol(npt + 1:npt + n) - tau * vlag(npt + 1:npt + n)) / denom +bmat = bmat + outprod(v1, vlag) + outprod(v2, hcol) !call r2update(bmat, ONE, v1, vlag, ONE, v2, hcol) +! N.B.: The use of OUTPROD is expensive memory-wise, but it is not our concern in this implementation. +! Numerically, the update above does not guarantee BMAT(:, NPT+1 : NPT+N) to be symmetric. +call symmetrize(bmat(:, npt + 1:npt + n)) + +! Apply Givens rotations to put zeros in the KNEW-th row of ZMAT. After this, ZMAT(KNEW, :) contains +! only one nonzero at ZMAT(KNEW, 1). Entries of ZMAT are treated as 0 if the moduli are quite small. +do j = 2, npt - n - 1_IK + if (abs(zmat(knew, j)) > 1.0E-20 * maxval(abs(zmat))) then ! This threshold is by Powell + grot = planerot(zmat(knew, [1_IK, j])) + zmat(:, [1_IK, j]) = matprod(zmat(:, [1_IK, j]), transpose(grot)) + end if + zmat(knew, j) = ZERO +end do + +! Complete the updating of ZMAT. See (4.14) of the BOBYQA paper. +sqrtdn = sqrt(denom) +zmat(:, 1) = (tau / sqrtdn) * zmat(:, 1) - (zmat(knew, 1) / sqrtdn) * vlag(1:npt) +! Zaikun 20231012: Either of the following two lines worsens the performance of BOBYQA when the +! objective function is evaluated with 5 or less correct significance digits. Strange. +! !zmat(:, 1) = (tau * zmat(:, 1) - zmat(knew, 1) * vlag(1:npt)) / sqrtdn +! !zmat(knew, 1) = zknew1 / sqrtdn ! ZKNEW1 is the unupdated ZMAT(KNEW, 1) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, 'SIZE(ZMAT) == [NPT, NPT-N-1]', srname) + + do j = 1, npt + hcol(1:npt) = matprod(zmat, zmat(j, :)) + hcol(npt + 1:npt + n) = bmat(:, j) + call assert(precision(0.0_RP) < precision(0.0D0) .or. sum(abs(hcol)) > 0, 'Column '//num2str(j)//' of H is nonzero', srname) + end do + + ! The following is too expensive to check. + ! !if (n * npt <= 50) then + ! ! xpt_test = xpt + ! ! xpt_test(:, knew) = xpt(:, kopt) + d + ! ! call assert(errh(bmat, zmat, xpt_test) <= tol .or. precision(0.0_RP) < precision(0.0D0), & + ! ! & 'H = W^{-1} in (2.7) of the BOBYQA paper', srname) + ! !end if +end if +end subroutine updateh + + +subroutine updatexf(knew, ximproved, f, xnew, kopt, fval, xpt) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates [XPT, FVAL, KOPT] so that XPT(:, KNEW) is updated to XNEW. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan, is_posinf + +implicit none + +! Inputs +integer(IK), intent(in) :: knew +real(RP), intent(in) :: f +real(RP), intent(in) :: xnew(:) ! XNEW(N) + +! In-outputs +integer(IK), intent(inout) :: kopt +logical, intent(in) :: ximproved +real(RP), intent(inout) :: fval(:) ! FVAL(NPT) +real(RP), intent(inout) :: xpt(:, :)! XPT(N, NPT) + +! Local variables +character(len=*), parameter :: srname = 'UPDATEXF' +integer(IK) :: n +integer(IK) :: npt + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless X is not improved', srname) + call assert(knew /= kopt .or. ximproved, 'KNEW /= KOPT unless X is improved', srname) + call assert(size(xnew) == n .and. all(is_finite(xnew)), 'SIZE(XNEW) == N, XNEW is finite', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN or +Inf', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(.not. any(fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Do essentially nothing when KNEW is 0. This can only happen after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +xpt(:, knew) = xnew +fval(knew) = f + +! KOPT is NOT identical to MINLOC(FVAL). Indeed, if FVAL(KNEW) = FVAL(KOPT) and KNEW < KOPT, then +! MINLOC(FVAL) = KNEW /= KOPT. Do not change KOPT in this case. +if (ximproved) then + kopt = knew +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt .and. all(is_finite(xpt)), & + & 'SIZE(XPT) == [N, NPT], XPT is finite', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(.not. any(fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) +end if + +end subroutine updatexf + + +subroutine updateq(knew, ximproved, bmat, d, moderr, xdrop, xosav, xpt, zmat, gopt, hq, pq) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates GOPT, HQ, and PQ when XPT(:, KNEW) changes from XDROP to XNEW = XOSAV + D, +! where XOSAV is the unupdated XOPT, namely the XOPT before UPDATEXF is called. +! See Section 4 of the NEWUOA paper and that of the BOBYQA paper (there is no LINCOA paper). +! N.B.: +! XNEW is encoded in [BMAT, ZMAT] after UPDATEH being called, and it also equals XPT(:, KNEW) +! after UPDATEXF being called. Indeed, we only need BMAT(:, KNEW) instead of the entire matrix. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : matprod, r1update, issymmetric +use, non_intrinsic :: powalg_mod, only : hess_mul + +implicit none + +! Inputs +integer(IK), intent(in) :: knew +logical, intent(in) :: ximproved +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: d(:) ! D(:) +real(RP), intent(in) :: moderr +real(RP), intent(in) :: xdrop(:) ! XDROP(N) +real(RP), intent(in) :: xosav(:) ! XOSAV(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! In-outputs +real(RP), intent(inout) :: gopt(:) ! GOPT(N) +real(RP), intent(inout) :: hq(:, :) ! HQ(N, N) +real(RP), intent(inout) :: pq(:) ! PQ(NPT) + +! Local variables +character(len=*), parameter :: srname = 'UPDATEQ' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: pqinc(size(pq)) + +! Sizes +n = int(size(gopt), kind(n)) +npt = int(size(pq), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless X is not improved', srname) + call assert(size(xdrop) == n .and. all(is_finite(xdrop)), 'SIZE(XDROP) == N, XDROP is finite', srname) + call assert(size(xosav) == n .and. all(is_finite(xosav)), 'SIZE(XOSAV) == N, XOSAV is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Do nothing when KNEW is 0. This can only happen after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +! The unupdated model corresponding to [GOPT, HQ, PQ] interpolates F at all points in XPT except for +! XNEW. The error is MODERR = [F(XNEW)-F(XOPT)] - [Q(XNEW)-Q(XOPT)]. + +! Absorb PQ(KNEW)*XDROP*XDROP^T into the explicit part of the Hessian. +! Implement R1UPDATE properly so that it ensures that HQ is symmetric. +call r1update(hq, pq(knew), xdrop) +pq(knew) = ZERO + +! Update the implicit part of the Hessian. +pqinc = moderr * matprod(zmat, zmat(knew, :)) ! pqinc = moderr * omega_col(1_IK, zmat, knew) +pq = pq + pqinc + +! Update the gradient, which needs the updated XPT. +gopt = gopt + moderr * bmat(:, knew) + hess_mul(xosav, xpt, pqinc) + +! Further update GOPT if XIMPROVED is TRUE, as XOPT changes from XOSAV to XNEW = XOSAV + D. +if (ximproved) then + gopt = gopt + hess_mul(d, xpt, pq, hq) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) +end if + +end subroutine updateq + + +subroutine tryqalt(bmat, fval, ratio, sl, su, xopt, xpt, zmat, itest, gopt, hq, pq) +!--------------------------------------------------------------------------------------------------! +! This subroutine tests whether to replace Q by the alternative model, namely the model that +! minimizes the F-norm of the Hessian subject to the interpolation conditions. It does the +! replacement if certain criteria are met (i.e., when ITEST = 3). See the paragraph around (6.12) of +! the BOBYQA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TEN, TENTH, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +use, non_intrinsic :: linalg_mod, only : matprod, inprod, issymmetric, trueloc +use, non_intrinsic :: powalg_mod, only : hess_mul + +implicit none + +! Inputs +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT+N) +real(RP), intent(in) :: fval(:) ! FVAL(NPT) +real(RP), intent(in) :: ratio +real(RP), intent(in) :: sl(:) ! SL(N) +real(RP), intent(in) :: su(:) ! SU(N) +real(RP), intent(in) :: xopt(:) ! XOPT(N) +real(RP), intent(in) :: xpt(:, :) ! XOPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT-N-1) + +! In-output +integer(IK), intent(inout) :: itest +real(RP), intent(inout) :: gopt(:) ! GOPT(N) +real(RP), intent(inout) :: hq(:, :) ! HQ(N, N) +real(RP), intent(inout) :: pq(:) ! PQ(NPT) +! N.B.: +! GOPT, HQ, and PQ should be INTENT(INOUT) instead of INTENT(OUT). According to the Fortran 2018 +! standard, an INTENT(OUT) dummy argument becomes undefined on invocation of the procedure. +! Therefore, if the procedure does not define such an argument, its value becomes undefined, +! which is the case for HQ and PQ when ITEST < 3 at exit. In addition, the information in GOPT is +! needed for defining ITEST, so it must be INTENT(INOUT). + +! Local variables +character(len=*), parameter :: srname = 'TRYQALT' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: galt(size(gopt)) +real(RP) :: pgalt(size(gopt)) +real(RP) :: pgopt(size(gopt)) +real(RP) :: pqalt(size(pq)) + +! Debugging variables +!real(RP) :: intp_tol + +! Sizes +n = int(size(gopt), kind(n)) +npt = int(size(pq), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + ! By the definition of RATIO in ratio.f90, RATIO cannot be NaN unless the actual reduction is + ! NaN, which should NOT happen due to the moderated extreme barrier. + call assert(.not. is_nan(ratio), 'RATIO is not NaN', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Calculate the norm square of the projected gradient. +pgopt = gopt +pgopt(trueloc(xopt >= su)) = max(ZERO, gopt(trueloc(xopt >= su))) +pgopt(trueloc(xopt <= sl)) = min(ZERO, gopt(trueloc(xopt <= sl))) + +! Calculate the parameters of the least Frobenius norm interpolant to the current data. +pqalt = matprod(zmat, matprod(fval, zmat)) +galt = matprod(bmat(:, 1:npt), fval) + hess_mul(xopt, xpt, pqalt) + +! Calculate the norm square of the projected alternative gradient. +pgalt = galt +pgalt(trueloc(xopt >= su)) = max(ZERO, galt(trueloc(xopt >= su))) +pgalt(trueloc(xopt <= sl)) = min(ZERO, galt(trueloc(xopt <= sl))) + +! Test whether to replace the new quadratic model by the least Frobenius norm interpolant, +! making the replacement if the test is satisfied. +! N.B.: In the following IF, Powell's condition does not check RATIO. The condition here (with RATIO +! > TENTH)is adopted and adapted from NEWUOA, and it seems to improve the performance. +! !if (inprod(pgopt, pgopt) < TEN * inprod(pgalt, pgalt)) then ! Powell's code +if (ratio > TENTH .or. inprod(pgopt, pgopt) < TEN * inprod(pgalt, pgalt)) then + itest = 0 +else + itest = itest + 1_IK +end if +if (itest >= 3) then + gopt = galt + pq = pqalt + hq = ZERO + itest = 0 +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) +end if + +end subroutine tryqalt + + +end module update_bobyqa_mod diff --git a/examples/fortran/prima/native/cobyla/cobyla.f90 b/examples/fortran/prima/native/cobyla/cobyla.f90 new file mode 100644 index 000000000..6794cdc1a --- /dev/null +++ b/examples/fortran/prima/native/cobyla/cobyla.f90 @@ -0,0 +1,867 @@ +module cobyla_mod +!--------------------------------------------------------------------------------------------------! +! COBYLA_MOD is a module providing the reference implementation of of Powell's COBYLA algorithm in +! +! M. J. D. Powell, A direct search optimization method that models the objective and constraint +! functions by linear interpolation, In Advances in Optimization and Numerical Analysis, eds. S. +! Gomez and J. P. Hennart, pages 51--67, Springer Verlag, Dordrecht, Netherlands, 1994 +! +! COBYLA approximately solves +! +! min F(X) subject to NLCONSTR(X) <= 0, Aineq*X <= Bineq, Aeq*x = Beq, XL <= X <= XU, +! +! where X is a vector of variables that has N components, F is a real-valued objective function, and +! NLCONSTR(X) is an M_NLCON-dimensional vector-valued mapping representing the nonlinear constraints, +! Aineq is an Mineq-by-N matrix, Bineq is an Mineq-dimensional real vector, Aeq is an Meq-by-N +! matrix, Beq is an Meq-dimensional real vector, XL is an N-dimensional real vector, and XU is an +! N-dimensional real vector. +! +! The algorithm employs linear approximations to the objective and nonlinear constraint functions, +! the approximations being formed by linear interpolation at N + 1 points in the space of the +! variables. We regard these interpolation points as vertices of a simplex. The parameter RHO +! controls the size of the simplex and it is reduced automatically from RHOBEG to RHOEND. For each +! RHO the subroutine tries to achieve a good vector of variables for the current size, and then RHO +! is reduced until the value RHOEND is reached. Therefore RHOBEG and RHOEND should be set to +! reasonable initial changes to and the required accuracy in the variables respectively, but this +! accuracy should be viewed as a subject for experimentation because it is not guaranteed. The +! subroutine has an advantage over many of its competitors, however, which is that it treats each +! constraint individually when calculating a change to the variables, instead of lumping the +! constraints together into a single penalty function. The name of the subroutine is derived from +! the phrase Constrained Optimization BY Linear Approximations. +! +! N.B.: +! 1. In Powell's implementation, the constraints are in the form of CONSTR(X) >= 0, whereas we +! consider CONSTR(X) <= 0, where CONSTR is a vector-valued function that wraps all constraints. +! 2. Powell's implementation does not deal with bound and linear constraints explicitly, but we do. +! 3. Our formulation of constraints is consistent with FMINCON of MATLAB. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on the COBYLA paper and Powell's code, with +! modernization, bug fixes, and improvements. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2021 +! +! Last Modified: Tue 16 Sep 2025 12:35:02 PM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: cobyla + + +contains + + +subroutine cobyla(calcfc, m_nlcon, x, & + & f, cstrv, nlconstr, & + & Aineq, bineq, & + & Aeq, beq, & + & xl, xu, & + & f0, nlconstr0, & + & nf, rhobeg, rhoend, ftarget, ctol, cweight, maxfun, iprint, eta1, eta2, gamma1, gamma2, & + & xhist, fhist, chist, nlchist, maxhist, maxfilt, callback_fcn, info) +!--------------------------------------------------------------------------------------------------! +! Among all the arguments, only CALCFC, M_NLCON, and X are obligatory. The others are OPTIONAL and +! you can neglect them unless you are familiar with the algorithm. Any unspecified optional input +! will take the default value detailed below. For instance, we may invoke the solver as follows. +! +! ! First define CALCFC, M_NLCON, and X, and then do the following. +! call cobyla(calcfc, m_nlcon, x, f, cstrv) +! +! or +! +! ! First define CALCFC, M_NLCON, X, Aineq, and Bineq, and then do the following. +! call cobyla(calcfc, m_nlcon, x, f, cstrv, Aineq = Aineq, bineq = bineq, rhobeg = 1.0D0, rhoend = 1.0D-6) +! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! IMPORTANT NOTICE: The user must set M_NLCON correctly to the number of nonlinear constraints, +! ! namely the size of NLCONSTR introduced below. Set it to 0 if there is no nonlinear constraint. +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! See examples/cobyla_exmp.f90 for a concrete example. +! +! A detailed introduction to the arguments is as follows. +! N.B.: RP and IK are defined in the module CONSTS_MOD. See consts.F90 under the directory named +! "common". By default, RP = kind(0.0D0) and IK = kind(0), with REAL(RP) being the double-precision +! real, and INTEGER(IK) being the default integer. For ADVANCED USERS, RP and IK can be defined by +! setting PRIMA_REAL_PRECISION and PRIMA_INTEGER_KIND in common/ppf.h. Use the default if unsure. +! +! CALCFC +! Input, subroutine. +! CALCFC(X, F, NLCONSTR) should evaluate the objective function and nonlinear constraints at the +! given REAL(RP) vector X; it should set the objective function value to the REAL(RP) scalar F +! and the nonlinear constraint value to the REAL(RP) vector NLCONSTR. It must be provided by the +! user, and its definition must conform to the following interface: +! !-------------------------------------------------------------------------! +! subroutine calcfc(x, f, nlconstr) +! real(RP), intent(in) :: x(:) +! real(RP), intent(out) :: f +! real(RP), intent(out) :: nlconstr(:) +! end subroutine calcfc +! !-------------------------------------------------------------------------! +! Besides, the subroutine should NOT access NLCONSTR beyond NLCONSTR(1:M_NLCON), where M_NLCON +! is the second compulsory argument (see below), signifying the number of nonlinear constraints. +! +! M_NLCON +! Input, INTEGER(IK) scalar. +! M_NLCON must be set to the number of nonlinear constraints, namely the size of NLCONSTR(X). +! N.B.: +! 1. M_NLCON must be specified correctly, or the program will crash!!! +! 2. Why don't we define M_NLCON as optional and default it to 0 when it is absent? This is +! because we need to allocate memory for CONSTR_LOC using M_NLCON. To ensure that the size of +! CONSTR_LOC is correct, we require the user to specify M_NLCON explicitly. +! +! X +! Input and output, REAL(RP) vector. +! As an input, X should be an N-dimensional vector that contains the starting point, N being the +! dimension of the problem. As an output, X will be set to an approximate minimizer. +! +! F +! Output, REAL(RP) scalar. +! F will be set to the objective function value of X at exit. +! +! CSTRV +! Output, REAL(RP) scalar. +! CSTRV will be set to the constraint violation of X at exit, i.e., +! MAXVAL([0, XL - X, X - XU, Aineq*X - Bineq, ABS(Aeq*X -Beq), NLCONSTR(X)]). +! +! NLCONSTR +! Output, REAL(RP) vector. +! NLCONSTR should be an M_NLCON-dimensional vector and will be set to the nonlinear constraint +! value of X at exit. +! +! Aineq, Bineq +! Input, REAL(RP) matrix of size [Mineq, N] and REAL vector of size Mineq unless they are both +! empty, default: [] and []. +! Aineq and Bineq represent the linear inequality constraints: Aineq*X <= Bineq. +! +! Aeq, Beq +! Input, REAL(RP) matrix of size [Meq, N] and REAL vector of size Meq unless they are both +! empty, default: [] and []. +! Aeq and Beq represent the linear equality constraints: Aeq*X = Beq. +! +! XL, XU +! Input, REAL(RP) vectors of size N unless they are both empty, default: [] and []. +! XL is the lower bound for X. Its size is either N or 0, the latter signifying that X has no +! lower bound. Any entry of XL that is NaN or below -BOUNDMAX will be taken as -BOUNDMAX, which +! effectively means there is no lower bound for the corresponding entry of X. The value of +! BOUNDMAX is 0.25*HUGE(X), which is about 8.6E37 for single precision and 4.5E307 for double +! precision. XU is similar. +! +! F0 +! Input, REAL(RP) scalar. +! F0, if present, should be set to the objective function value of the starting X. +! +! NLCONSTR0 +! Input, REAL(RP) vector. +! NLCONSTR0, if present, should be set to the nonlinear constraint value at the starting X; in +! addition, SIZE(NLCONSTR0) must be M_NLCON, or the solver will abort. +! +! NF +! Output, INTEGER(IK) scalar. +! NF will be set to the number of calls of CALCFC at exit. +! +! RHOBEG, RHOEND +! Inputs, REAL(RP) scalars, default: RHOBEG = 1, RHOEND = 10^-6. RHOBEG and RHOEND must be set to +! the initial and final values of a trust-region radius, both being positive and RHOEND <= RHOBEG. +! Typically RHOBEG should be about one tenth of the greatest expected change to a variable, and +! RHOEND should indicate the accuracy that is required in the final values of the variables. +! +! FTARGET +! Input, REAL(RP) scalar, default: -Inf. +! FTARGET is the target function value. The algorithm will terminate when a feasible point with a +! function value <= FTARGET is found. +! +! CTOL +! Input, REAL(RP) scalar, default: machine epsilon. +! CTOL is the tolerance of constraint violation. X is considered feasible if CSTRV(X) <= CTOL. +! N.B.: 1. CTOL is absolute, not relative. 2. CTOL is used only when selecting the returned X. +! It does not affect the iterations of the algorithm. +! +! CWEIGHT +! Input, REAL(RP) scalar, default: CWEIGHT_DFT defined in the module CONSTS_MOD in common/consts.F90. +! CWEIGHT is the weight that the constraint violation takes in the selection of the returned X. +! +! MAXFUN +! Input, INTEGER(IK) scalar, default: MAXFUN_DIM_DFT*N with MAXFUN_DIM_DFT defined in the module +! CONSTS_MOD (see common/consts.F90). MAXFUN is the maximal number of calls of CALCFC. +! +! IPRINT +! Input, INTEGER(IK) scalar, default: 0. +! The value of IPRINT should be set to 0, 1, -1, 2, -2, 3, or -3, which controls how much +! information will be printed during the computation: +! 0: there will be no printing; +! 1: a message will be printed to the screen at the return, showing the best vector of variables +! found and its objective function value; +! 2: in addition to 1, each new value of RHO is printed to the screen, with the best vector of +! variables so far and its objective function value; each new value of CPEN is also printed; +! 3: in addition to 2, each function evaluation with its variables will be printed to the screen; +! -1, -2, -3: the same information as 1, 2, 3 will be printed, not to the screen but to a file +! named COBYLA_output.txt; the file will be created if it does not exist; the new output will +! be appended to the end of this file if it already exists. +! Note that IPRINT = +/-3 can be costly in terms of time and/or space. +! +! ETA1, ETA2, GAMMA1, GAMMA2 +! Input, REAL(RP) scalars, default: ETA1 = 0.1, ETA2 = 0.7, GAMMA1 = 0.5, and GAMMA2 = 2. +! ETA1, ETA2, GAMMA1, and GAMMA2 are parameters in the updating scheme of the trust-region radius +! detailed in the subroutine TRRAD in trustregion.f90. Roughly speaking, the trust-region radius +! is contracted by a factor of GAMMA1 when the reduction ratio is below ETA1, and enlarged by a +! factor of GAMMA2 when the reduction ratio is above ETA2. It is required that 0 < ETA1 <= ETA2 +! < 1 and 0 < GAMMA1 < 1 < GAMMA2. Normally, ETA1 <= 0.25. It is NOT advised to set ETA1 >= 0.5. +! +! XHIST, FHIST, CHIST, NLCHIST, MAXHIST +! XHIST: Output, ALLOCATABLE rank 2 REAL(RP) array; +! FHIST: Output, ALLOCATABLE rank 1 REAL(RP) array; +! CHIST: Output, ALLOCATABLE rank 1 REAL(RP) array; +! NLCHIST: Output, ALLOCATABLE rank 2 REAL(RP) array; +! MAXHIST: Input, INTEGER(IK) scalar, default: MAXFUN +! XHIST, if present, will output the history of iterates; FHIST, if present, will output the +! history function values; CHIST, if present, will output the history of constraint violations; +! NLCHIST, if present, will output the history of nonlinear constraint values; MAXHIST should be +! a nonnegative integer, and XHIST/FHIST/CHIST/NLCHIST will output only the history of the last +! MAXHIST iterations. Therefore, MAXHIST= 0 means XHIST/FHIST/NLCHIST/CHIST will output nothing, +! while setting MAXHIST = MAXFUN requests XHIST/FHIST/CHIST/NLCHIST to output all the history. +! If XHIST is present, its size at exit will be (N, min(NF, MAXHIST)); if FHIST is present, its +! size at exit will be min(NF, MAXHIST); if CHIST is present, its size at exit will be +! min(NF, MAXHIST); if NLCHIST is present, its size at exit will be (M_NLCON, min(NF, MAXHIST)). +! +! IMPORTANT NOTICE: +! Setting MAXHIST to a large value can be costly in terms of memory for large problems. +! MAXHIST will be reset to a smaller value if the memory needed exceeds MAXHISTMEM defined in +! CONSTS_MOD (see consts.F90 under the directory named "common"). +! Use *HIST with caution!!! (N.B.: the algorithm is NOT designed for large problems). +! +! MAXFILT +! Input, INTEGER(IK) scalar. +! MAXFILT is a nonnegative integer indicating the maximal length of the filter used for selecting +! the returned solution; default: MAXFILT_DFT (a value lower than MIN_MAXFILT is not recommended); +! see common/consts.F90 for the definitions of MAXFILT_DFT and MIN_MAXFILT. +! +! CALLBACK_FCN +! Input, function to report progress and optionally request termination. +! +! INFO +! Output, INTEGER(IK) scalar. +! INFO is the exit flag. It will be set to one of the following values defined in the module +! INFOS_MOD (see common/infos.f90): +! SMALL_TR_RADIUS: the lower bound for the trust region radius is reached; +! FTARGET_ACHIEVED: the target function value is reached; +! MAXFUN_REACHED: the objective function has been evaluated MAXFUN times; +! MAXTR_REACHED: the trust region iteration has been performed MAXTR times (MAXTR = 2*MAXFUN); +! NAN_INF_X: NaN or Inf occurs in X; +! DAMAGING_ROUNDING: rounding errors are becoming damaging. +! !--------------------------------------------------------------------------! +! The following case(s) should NEVER occur unless there is a bug. +! NAN_INF_F: the objective function returns NaN or +Inf; +! NAN_INF_MODEL: NaN or Inf occurs in the model; +! TRSUBP_FAILED: a trust region step failed to reduce the model +! !--------------------------------------------------------------------------! +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : DEBUGGING +use, non_intrinsic :: consts_mod, only : MAXFUN_DIM_DFT, MAXFILT_DFT, IPRINT_DFT +use, non_intrinsic :: consts_mod, only : RHOBEG_DFT, RHOEND_DFT, CTOL_DFT, CWEIGHT_DFT, FTARGET_DFT +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TWO, HALF, TEN, TENTH, EPS, BOUNDMAX +use, non_intrinsic :: debug_mod, only : assert, errstop, warning +use, non_intrinsic :: evaluate_mod, only : evaluate, moderatex, moderatec, moderatef +use, non_intrinsic :: history_mod, only : prehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: infos_mod, only : INVALID_INPUT +use, non_intrinsic :: linalg_mod, only : trueloc, matprod, maximum +use, non_intrinsic :: memory_mod, only : safealloc +use, non_intrinsic :: pintrf_mod, only : OBJCON, CALLBACK +use, non_intrinsic :: selectx_mod, only : isbetter +use, non_intrinsic :: preproc_mod, only : preproc +use, non_intrinsic :: string_mod, only : num2str + +! Solver-specific modules +use, non_intrinsic :: cobylb_mod, only : cobylb + +implicit none + +! Compulsory arguments +procedure(OBJCON) :: calcfc ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +real(RP), intent(inout) :: x(:) ! X(N) +integer(IK), intent(in) :: m_nlcon ! Number of constraints defined in CALCFC + +! Optional inputs +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in), optional :: iprint +integer(IK), intent(in), optional :: maxfilt +integer(IK), intent(in), optional :: maxfun +integer(IK), intent(in), optional :: maxhist +real(RP), intent(in), optional :: Aeq(:, :) ! Aeq(Meq, N) +real(RP), intent(in), optional :: Aineq(:, :) ! Aineq(Mineq, N) +real(RP), intent(in), optional :: beq(:) ! Beq(Meq) +real(RP), intent(in), optional :: bineq(:) ! Bineq(Mineq) +real(RP), intent(in), optional :: nlconstr0(:) ! NLCONSTR0(M_NLCON) +real(RP), intent(in), optional :: ctol +real(RP), intent(in), optional :: cweight +real(RP), intent(in), optional :: eta1 +real(RP), intent(in), optional :: eta2 +real(RP), intent(in), optional :: f0 +real(RP), intent(in), optional :: ftarget +real(RP), intent(in), optional :: gamma1 +real(RP), intent(in), optional :: gamma2 +real(RP), intent(in), optional :: rhobeg +real(RP), intent(in), optional :: rhoend +real(RP), intent(in), optional :: xl(:) ! XL(N) +real(RP), intent(in), optional :: xu(:) ! XU(N) + +! Optional outputs +integer(IK), intent(out), optional :: info +integer(IK), intent(out), optional :: nf +real(RP), intent(out), optional :: cstrv +real(RP), intent(out), optional :: f +real(RP), intent(out), optional :: nlconstr(:) ! NLCONSTR(M_NLCON) +real(RP), intent(out), optional, allocatable :: chist(:) ! CHIST(MAXCHIST) +real(RP), intent(out), optional, allocatable :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out), optional, allocatable :: nlchist(:, :) ! NLCHIST(M_NLCON, MAXCONHIST) +real(RP), intent(out), optional, allocatable :: xhist(:, :) ! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'COBYLA' +character(len=*), parameter :: srname = 'COBYLA' +integer(IK) :: info_loc +integer(IK) :: iprint_loc +integer(IK) :: m +integer(IK) :: maxfilt_loc +integer(IK) :: maxfun_loc +integer(IK) :: maxhist_loc +integer(IK) :: meq +integer(IK) :: mineq +integer(IK) :: mxl +integer(IK) :: mxu +integer(IK) :: n +integer(IK) :: nf_loc +integer(IK) :: nhist +integer(IK), allocatable :: ixl(:) +integer(IK), allocatable :: ixu(:) +real(RP) :: cstrv_loc +real(RP) :: ctol_loc +real(RP) :: cweight_loc +real(RP) :: eta1_loc +real(RP) :: eta2_loc +real(RP) :: f_loc +real(RP) :: ftarget_loc +real(RP) :: gamma1_loc +real(RP) :: gamma2_loc +real(RP) :: rhobeg_loc +real(RP) :: rhoend_loc +real(RP) :: xl_loc(size(x)) +real(RP) :: xu_loc(size(x)) +real(RP), allocatable :: Aeq_loc(:, :) ! Aeq_LOC(Meq, N) +real(RP), allocatable :: Aineq_loc(:, :) ! Aineq_LOC(Mineq, N) +real(RP), allocatable :: amat(:, :) ! AMAT(N, M_LCON); each column corresponds to a linear constraint +real(RP), allocatable :: beq_loc(:) ! Beq_LOC(Meq) +real(RP), allocatable :: bineq_loc(:) ! Bineq_LOC(Mineq) +real(RP), allocatable :: bvec(:) ! BVEC(M_LCON) +real(RP), allocatable :: chist_loc(:) ! CHIST_LOC(MAXCHIST) +real(RP), allocatable :: conhist_loc(:, :) ! CONHIST_LOC(M, MAXCONHIST) +real(RP), allocatable :: constr_loc(:) ! CONSTR_LOC(M) +real(RP), allocatable :: fhist_loc(:) ! FHIST_LOC(MAXFHIST) +real(RP), allocatable :: xhist_loc(:, :) ! XHIST_LOC(N, MAXXHIST) + +! Sizes +if (present(bineq)) then + mineq = int(size(bineq), kind(mineq)) +else + mineq = 0 +end if +if (present(beq)) then + meq = int(size(beq), kind(meq)) +else + meq = 0 +end if +if (present(xl)) then + mxl = int(count(xl > -BOUNDMAX), kind(mxl)) +else + mxl = 0 +end if +if (present(xu)) then + mxu = int(count(xu < BOUNDMAX), kind(mxu)) +else + mxu = 0 +end if +m = mxu + mxl + 2_IK * meq + mineq + m_nlcon +n = int(size(x), kind(n)) + + +! Preconditions +if (DEBUGGING) then + call assert(m_nlcon >= 0, 'M_NLCON >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + if (present(nlconstr)) then + call assert(size(nlconstr) == m_nlcon, 'SIZE(NLCONSTR) == M_NLCON', srname) + end if + call assert(present(Aineq) .eqv. present(bineq), 'Aineq and Bineq are both present or both absent', srname) + if (present(Aineq)) then + call assert((size(Aineq, 1) == mineq .and. size(Aineq, 2) == n) & + & .or. (size(Aineq, 1) == 0 .and. size(Aineq, 2) == 0 .and. mineq == 0), & + & 'SIZE(Aineq) == [Mineq, N] unless Aineq and Bineq are both empty', srname) + end if + call assert(present(Aeq) .eqv. present(beq), 'Aeq and Beq are both present or both absent', srname) + if (present(Aeq)) then + call assert((size(Aeq, 1) == meq .and. size(Aeq, 2) == n) & + & .or. (size(Aeq, 1) == 0 .and. size(Aeq, 2) == 0 .and. meq == 0), & + & 'SIZE(Aeq) == [Meq, N] unless Aeq and Beq are both empty', srname) + end if + if (present(xl)) then + call assert(size(xl) == n .or. size(xl) == 0, 'SIZE(XL) == N unless XL is empty', srname) + end if + if (present(xu)) then + call assert(size(xu) == n .or. size(xu) == 0, 'SIZE(XU) == N unless XU is empty', srname) + end if + + ! N.B.: If NLCONSTR0 is present, then F0 must be present, and we assume that F(X0) = F0 even if + ! F0 is NaN; if NLCONSTR0 is absent, then F0 must be either absent or NaN, both of which will + ! be interpreted as F(X0) is not provided. + if (present(nlconstr0)) then + call assert(present(f0), 'If NLCONSTR0 is present, then F0 is present', srname) + end if + if (present(f0)) then + call assert(is_nan(f0) .or. present(nlconstr0), 'If F0 is present and not NaN, then NLCONSTR0 is present', srname) + end if +end if + +! Exit if the size of NLCONSTR0 is inconsistent with M_NLCON. +if (present(nlconstr0)) then + if (size(nlconstr0) /= m_nlcon) then + if (DEBUGGING) then + call errstop(srname, 'SIZE(NLCONSTR0) /= M_NLCON. Exiting', INVALID_INPUT) + else + call warning(srname, 'SIZE(NLCONSTR0) /= M_NLCON. Exiting') + return ! This may be problematic, as outputs like F are undefined. + end if + end if +end if + + +! Read the inputs. + +call safealloc(Aineq_loc, mineq, n) ! NOT removable even in F2003, as Aineq may be absent or of size 0-by-0. +if (present(Aineq) .and. mineq > 0) then + ! We must check Mineq > 0. Otherwise, the size of Aineq_LOC may be changed to 0-by-0 due to + ! automatic (re)allocation if that is the size of Aineq; we allow Aineq to be 0-by-0, but + ! Aineq_LOC should be n-by-0. + Aineq_loc = Aineq +end if + +call safealloc(bineq_loc, mineq) ! NOT removable even in F2003, as Bineq may be absent. +if (present(bineq)) then + bineq_loc = bineq +end if + +call safealloc(Aeq_loc, meq, n) ! NOT removable even in F2003, as Aeq may be absent or of size 0-by-0. +if (present(Aeq) .and. meq > 0) then + ! We must check Meq > 0. Otherwise, the size of Aeq_LOC may be changed to 0-by-0 due to + ! automatic (re)allocation if that is the size of Aeq; we allow Aeq to be 0-by-0, but + ! Aeq_LOC should be n-by-0. + Aeq_loc = Aeq +end if + +call safealloc(beq_loc, meq) ! NOT removable even in F2003, as Beq may be absent. +if (present(beq)) then + beq_loc = beq +end if + +xl_loc = -BOUNDMAX +if (present(xl)) then + if (size(xl) > 0) then + xl_loc = xl + end if +end if +xl_loc(trueloc(is_nan(xl_loc) .or. xl_loc < -BOUNDMAX)) = -BOUNDMAX +call safealloc(ixl, mxl) +ixl = trueloc(xl_loc > -BOUNDMAX) + +xu_loc = BOUNDMAX +if (present(xu)) then + if (size(xu) > 0) then + xu_loc = xu + end if +end if +xu_loc(trueloc(is_nan(xu_loc) .or. xu_loc > BOUNDMAX)) = BOUNDMAX +call safealloc(ixu, mxu) +ixu = trueloc(xu_loc < BOUNDMAX) + +! Wrap the linear and bound constraints into a single constraint: AMAT^T*X <= BVEC. +call get_lincon(Aeq_loc, Aineq_loc, beq_loc, bineq_loc, xl_loc, xu_loc, amat, bvec) + +! Allocate memory for CONSTR_LOC. +call safealloc(constr_loc, m) ! NOT removable even in F2003! + +! Set [F_LOC, CONSTR_LOC] to [F(X0), CONSTR(X0)] after evaluating the latter if needed. In this way, +! COBYLB only needs one interface. +! N.B.: Due to the preconditions above, there are two possibilities for F0 and NLCONSTR0. +! If NLCONSTR0 is present, then F0 must be present, and we assume that F(X0) = F0 even if F0 is NaN. +! If NLCONSTR0 is absent, then F0 must be either absent or NaN, both of which will be interpreted as +! F(X0) is not provided and we have to evaluate F(X0) and NLCONSTR(X0) now. +constr_loc(1:m - m_nlcon) = moderatec(matprod(x, amat) - bvec) ! Linear and bound constraints +! Note that EVALUATE moderates the nonlinear constraint values. Thus we also moderate the +! bound/linear constraint values here to make CSTRV consistent. +if (present(f0) .and. present(nlconstr0) .and. all(is_finite(x))) then + f_loc = moderatef(f0) + constr_loc(m - m_nlcon + 1:m) = moderatec(nlconstr0) +else + x = moderatex(x) + call evaluate(calcfc, x, f_loc, constr_loc(m - m_nlcon + 1:m)) ! Nonlinear constraints + ! N.B.: Do NOT call FMSG, SAVEHIST, or SAVEFILT for the function/constraint evaluation at X0. + ! They will be called during the initialization, which will read the function/constraint at X0. +end if +cstrv_loc = maximum([ZERO, constr_loc]) + +! If RHOBEG is present, then RHOBEG_LOC is a copy of RHOBEG; otherwise, RHOBEG_LOC takes the default +! value for RHOBEG, taking the value of RHOEND into account. Note that RHOEND is considered only if +! it is present and it is VALID (i.e., finite and positive). The other inputs are read similarly. +if (present(rhobeg)) then + rhobeg_loc = rhobeg +elseif (present(rhoend)) then + ! Fortran does not take short-circuit evaluation of logic expressions. Thus it is WRONG to + ! combine the evaluation of PRESENT(RHOEND) and the evaluation of IS_FINITE(RHOEND) as + ! "IF (PRESENT(RHOEND) .AND. IS_FINITE(RHOEND))". The compiler may choose to evaluate the + ! IS_FINITE(RHOEND) even if PRESENT(RHOEND) is false! + if (is_finite(rhoend) .and. rhoend > 0) then + rhobeg_loc = max(TEN * rhoend, RHOBEG_DFT) + else + rhobeg_loc = RHOBEG_DFT + end if +else + rhobeg_loc = RHOBEG_DFT +end if + +if (present(rhoend)) then + rhoend_loc = rhoend +elseif (rhobeg_loc > 0) then + rhoend_loc = max(EPS, min((RHOEND_DFT / RHOBEG_DFT) * rhobeg_loc, RHOEND_DFT)) +else + rhoend_loc = RHOEND_DFT +end if + +if (present(ctol)) then + ctol_loc = ctol +else + ctol_loc = CTOL_DFT +end if + +if (present(cweight)) then + cweight_loc = cweight +else + cweight_loc = CWEIGHT_DFT +end if + +if (present(ftarget)) then + ftarget_loc = ftarget +else + ftarget_loc = FTARGET_DFT +end if + +if (present(maxfun)) then + maxfun_loc = maxfun +else + maxfun_loc = MAXFUN_DIM_DFT * n +end if + +if (present(iprint)) then + iprint_loc = iprint +else + iprint_loc = IPRINT_DFT +end if + +if (present(eta1)) then + eta1_loc = eta1 +elseif (present(eta2)) then + if (eta2 > 0 .and. eta2 < 1) then + eta1_loc = max(EPS, eta2 / 7.0_RP) + end if +else + eta1_loc = TENTH +end if + +if (present(eta2)) then + eta2_loc = eta2 +elseif (eta1_loc > 0 .and. eta1_loc < 1) then + eta2_loc = (eta1_loc + TWO) / 3.0_RP +else + eta2_loc = 0.7_RP +end if + +if (present(gamma1)) then + gamma1_loc = gamma1 +else + gamma1_loc = HALF +end if + +if (present(gamma2)) then + gamma2_loc = gamma2 +else + gamma2_loc = TWO +end if + +if (present(maxhist)) then + maxhist_loc = maxhist +else + maxhist_loc = maxval([maxfun_loc, n + 2_IK, MAXFUN_DIM_DFT * n]) +end if + +if (present(maxfilt)) then + maxfilt_loc = maxfilt +else + maxfilt_loc = MAXFILT_DFT +end if + +! Preprocess the inputs in case some of them are invalid. It does nothing if all inputs are valid. +call preproc(solver, n, iprint_loc, maxfun_loc, maxhist_loc, ftarget_loc, rhobeg_loc, rhoend_loc, & + & m=m, is_constrained=(m > 0), ctol=ctol_loc, cweight=cweight_loc, eta1=eta1_loc, & + & eta2=eta2_loc, gamma1=gamma1_loc, gamma2=gamma2_loc, maxfilt=maxfilt_loc) + +! Further revise MAXHIST_LOC according to MAXHISTMEM, and allocate memory for the history. +! In MATLAB/Python/Julia/R implementation, we should simply set MAXHIST = MAXFUN and initialize +! CHIST = NaN(1, MAXFUN), NLCHIST = NaN(M_NLCON, MAXFUN), FHIST = NaN(1, MAXFUN), XHIST = +! NaN(N, MAXFUN) if they are requested; replace MAXFUN with 0 for the history not requested. +call prehist(maxhist_loc, n, present(xhist), xhist_loc, present(fhist), fhist_loc, & + & present(chist), chist_loc, m, present(nlchist), conhist_loc) + + +!-------------------- Call COBYLB, which performs the real calculations. --------------------------! +if (present(callback_fcn)) then + call cobylb(calcfc, iprint_loc, maxfilt_loc, maxfun_loc, amat, bvec, ctol_loc, cweight_loc, & + & eta1_loc, eta2_loc, ftarget_loc, gamma1_loc, gamma2_loc, rhobeg_loc, rhoend_loc, constr_loc, & + & f_loc, x, nf_loc, chist_loc, conhist_loc, cstrv_loc, fhist_loc, xhist_loc, info_loc, callback_fcn) +else + call cobylb(calcfc, iprint_loc, maxfilt_loc, maxfun_loc, amat, bvec, ctol_loc, cweight_loc, & + & eta1_loc, eta2_loc, ftarget_loc, gamma1_loc, gamma2_loc, rhobeg_loc, rhoend_loc, constr_loc, & + & f_loc, x, nf_loc, chist_loc, conhist_loc, cstrv_loc, fhist_loc, xhist_loc, info_loc) +end if +!--------------------------------------------------------------------------------------------------! + +! Deallocate variables not needed any more. We prefer explicit deallocation to the automatic one. +deallocate (Aineq_loc, Aeq_loc, amat, bineq_loc, beq_loc, bvec) + + +! Write the outputs. + +if (present(f)) then + f = f_loc +end if + +if (present(cstrv)) then + cstrv = cstrv_loc +end if + +if (present(nlconstr)) then + nlconstr = constr_loc(m - m_nlcon + 1:m) +end if +deallocate (constr_loc) + +if (present(nf)) then + nf = nf_loc +end if + +if (present(info)) then + info = info_loc +end if + +! Copy XHIST_LOC to XHIST if needed. +if (present(xhist)) then + nhist = min(nf_loc, int(size(xhist_loc, 2), IK)) + !----------------------------------------------------! + call safealloc(xhist, n, nhist) ! Removable in F2003. + !----------------------------------------------------! + xhist = xhist_loc(:, 1:nhist) + ! N.B.: + ! 0. Allocate XHIST as long as it is present, even if the size is 0; otherwise, it will be + ! illegal to enquire XHIST after exit. + ! 1. Even though Fortran 2003 supports automatic (re)allocation of allocatable arrays upon + ! intrinsic assignment, we keep the line of SAFEALLOC, because some very new compilers (Absoft + ! Fortran 21.0) are still not standard-compliant in this respect. + ! 2. NF may not be present. Hence we should NOT use NF but NF_LOC. + ! 3. When SIZE(XHIST_LOC, 2) > NF_LOC, which is the normal case in practice, XHIST_LOC contains + ! GARBAGE in XHIST_LOC(:, NF_LOC + 1 : END). Therefore, we MUST cap XHIST at NF_LOC so that + ! XHIST contains only valid history. For this reason, there is no way to avoid allocating + ! two copies of memory for XHIST unless we declare it to be a POINTER instead of ALLOCATABLE. +end if +! F2003 automatically deallocate local ALLOCATABLE variables at exit, yet we prefer to deallocate +! them immediately when they finish their jobs. +deallocate (xhist_loc) + +! Copy FHIST_LOC to FHIST if needed. +if (present(fhist)) then + nhist = min(nf_loc, int(size(fhist_loc), IK)) + !--------------------------------------------------! + call safealloc(fhist, nhist) ! Removable in F2003. + !--------------------------------------------------! + fhist = fhist_loc(1:nhist) ! The same as XHIST, we must cap FHIST at NF_LOC. +end if +deallocate (fhist_loc) + +! Copy CHIST_LOC to CHIST if needed. +if (present(chist)) then + nhist = min(nf_loc, int(size(chist_loc), IK)) + !--------------------------------------------------! + call safealloc(chist, nhist) ! Removable in F2003. + !--------------------------------------------------! + chist = chist_loc(1:nhist) ! The same as XHIST, we must cap CHIST at NF_LOC. +end if +deallocate (chist_loc) + +! Copy CONHIST_LOC to NLCHIST if needed. +! N.B.: We need only the nonlinear part of the history. Therefore, one may modify COBYLB so that it +! records only the history of nonlinear constraints rather than that of all constraints, which is +! what CONHIST_LOC records in the current implementation. This will save memory and time, but will +! complicate a bit the code of COBYLB. We prefer to keep the code simple, assuming that such a +! difference in memory and time is not a problem in the context of derivative-free optimization. +! A similar comment can be made on CONSTR_LOC and NLCONSTR, which are related to CONFILT in COBYLB. +if (present(nlchist)) then + nhist = min(nf_loc, int(size(conhist_loc, 2), IK)) + !---------------------------------------------------------------! + call safealloc(nlchist, m_nlcon, nhist) ! Removable in F2003. + !---------------------------------------------------------------! + nlchist = conhist_loc(m - m_nlcon + 1:m, 1:nhist) ! The same as XHIST, we must cap NLCHIST at NF_LOC. +end if +deallocate (conhist_loc) + +! If NF_LOC > MAXHIST_LOC, warn that not all history is recorded. +if ((present(xhist) .or. present(fhist) .or. present(chist) .or. present(nlchist)) .and. maxhist_loc < nf_loc) then + call warning(solver, 'Only the history of the last '//num2str(maxhist_loc)//' function evaluation(s) is recorded') +end if + +! Postconditions +if (DEBUGGING) then + call assert(nf_loc <= maxfun_loc, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + nhist = min(nf_loc, maxhist_loc) + if (present(xhist)) then + call assert(size(xhist, 1) == n .and. size(xhist, 2) == nhist, 'SIZE(XHIST) == [N, NHIST]', srname) + call assert(.not. any(is_nan(xhist)), 'XHIST does not contain NaN', srname) + end if + if (present(fhist)) then + call assert(size(fhist) == nhist, 'SIZE(FHIST) == NHIST', srname) + call assert(.not. any(is_nan(fhist) .or. is_posinf(fhist)), 'FHIST does not contain NaN/+Inf', srname) + end if + if (present(chist)) then + call assert(size(chist) == nhist, 'SIZE(CHIST) == NHIST', srname) + call assert(.not. any(chist < 0 .or. is_nan(chist) .or. is_posinf(chist)), & + & 'CHIST does not contain nonnegative values or NaN/+Inf', srname) + end if + if (present(nlchist)) then + call assert(size(nlchist, 1) == m_nlcon .and. size(nlchist, 2) == nhist, 'SIZE(NLCHIST) == [M_NLCON, NHIST]', srname) + call assert(.not. any(is_nan(nlchist) .or. is_posinf(nlchist)), 'NLCHIST does not contain NaN/+Inf', srname) + end if + if (present(fhist) .and. present(chist)) then + call assert(.not. any(isbetter(fhist(1:nhist), chist(1:nhist), f_loc, cstrv_loc, ctol_loc)), & + & 'No point in the history is better than X', srname) + end if +end if + +end subroutine cobyla + + +subroutine get_lincon(Aeq, Aineq, beq, bineq, xl, xu, amat, bvec) +!--------------------------------------------------------------------------------------------------! +! This subroutine wraps the linear and bound constraints into a single constraint: AMAT^T*X <= BVEC. +! N.B.: +! 1. The linear inequality constraints received by COBYLA is AMAT^T * X <= BVEC. Note that Each +! column of AMAT corresponds to a constraint. This is different from Aineq and Aeq, whose rows +! correspond to constraints. AMAT is defined in this way because it is accessed in columns during +! the computation, and because Fortran saves arrays in the column-major order. In Python/C +! implementations, AMAT should be transposed. +! 2. LINCOA normalizes the linear constraints so that each constraint has a gradient of norm 1. +! However, COBYLA does not do this. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, BOUNDMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : eye, trueloc +use, non_intrinsic :: memory_mod, only : safealloc + +implicit none + +! Inputs +real(RP), intent(in) :: Aeq(:, :) +real(RP), intent(in) :: Aineq(:, :) +real(RP), intent(in) :: beq(:) +real(RP), intent(in) :: bineq(:) +real(RP), intent(in) :: xl(:) +real(RP), intent(in) :: xu(:) + +! Outputs +real(RP), intent(out), allocatable :: amat(:, :) +real(RP), intent(out), allocatable :: bvec(:) + +! Local variables +character(len=*), parameter :: srname = 'GET_LINCON' +integer(IK) :: m_lcon +integer(IK) :: meq +integer(IK) :: mineq +integer(IK) :: mxl +integer(IK) :: mxu +integer(IK) :: n +integer(IK), allocatable :: ixl(:) +integer(IK), allocatable :: ixu(:) +real(RP) :: idmat(size(xl), size(xl)) + +! Sizes +n = int(size(xl), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(Aineq, 1) == size(bineq) .and. size(Aineq, 2) == n, 'SIZE(AINEQ) == [SIZE(BINEQ), N]', srname) + call assert(size(Aeq, 1) == size(beq) .and. size(Aeq, 2) == n, 'SIZE(AEQ) == [SIZE(BEQ), N]', srname) + call assert(size(xl) == n .and. size(xu) == n, 'SIZE(XL) == SIZE(XU) == N', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Decide the number of nontrivial constraints. +mxl = int(count(xl > -BOUNDMAX), kind(mxl)) +mxu = int(count(xu < BOUNDMAX), kind(mxu)) +meq = int(size(beq), kind(meq)) +mineq = int(size(bineq), kind(mineq)) +m_lcon = mxl + mxu + 2_IK * meq + mineq ! The final number of linear inequality constraints. + +! Allocate memory. Removable in F2003. +call safealloc(ixl, mxl) +call safealloc(ixu, mxu) +call safealloc(amat, n, m_lcon) +call safealloc(bvec, m_lcon) + +! Define the indices of the nontrivial bound constraints. +ixl = trueloc(xl > -BOUNDMAX) +ixu = trueloc(xu < BOUNDMAX) + +! Wrap the linear constraints. +! The bound constraint XL <= X <= XU is handled as two constraints -X <= -XL, X <= XU. +! The equality constraint Aeq*X = Beq is handled as two constraints -Aeq*X <= -Beq, Aeq*X <= Beq. +! N.B.: +! 1. The treatment of the equality constraints is naive. One may choose to eliminate them instead. +! 2. The code below is quite inefficient in terms of memory, but we prefer readability. +idmat = eye(n, n) +amat = reshape(shape=shape(amat), source= & + & [-idmat(:, ixl), idmat(:, ixu), -transpose(Aeq), transpose(Aeq), transpose(Aineq)]) +bvec = [-xl(ixl), xu(ixu), -beq, beq, bineq] +!!MATLAB code: +!!amat = [-idmat(:, ixl), idmat(:, ixu), -Aeq', Aeq', Aineq']; +!!bvec = [-xl(ixl); xu(ixu); -beq; beq; bineq]; + +! Deallocate memory. +deallocate (ixl, ixu) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(amat, 1) == size(xl) .and. size(amat, 2) == size(bvec), & + & 'SIZE(AMAT) == [SIZE(X), SIZE(BVEC)]', srname) +end if +end subroutine get_lincon + + +end module cobyla_mod diff --git a/examples/fortran/prima/native/cobyla/cobylb.f90 b/examples/fortran/prima/native/cobyla/cobylb.f90 new file mode 100644 index 000000000..f64abb7db --- /dev/null +++ b/examples/fortran/prima/native/cobyla/cobylb.f90 @@ -0,0 +1,939 @@ +! TODO: Implement GETMODEL to get the model of the objective function and constraints, i.e., g and A. +module cobylb_mod +!--------------------------------------------------------------------------------------------------! +! This module performs the major calculations of COBYLA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the COBYLA paper. +! +! N.B. (Zaikun 20220131): Powell's implementation of COBYLA uses RHO rather than DELTA as the +! trust-region radius, and RHO is never increased. DELTA does not exist in Powell's COBYLA code. +! Following the idea in Powell's other solvers (UOBYQA, ..., LINCOA), our code uses DELTA as the +! trust-region radius, while RHO works a lower bound of DELTA and indicates the current resolution +! of the algorithm. DELTA is updated in a classical way subject to DELTA >= RHO, whereas RHO is +! updated as in Powell's COBYLA code and is never increased. The new implementation improves the +! performance of COBYLA. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2021 +! +! Last Modified: Wed 08 Apr 2026 06:38:14 PM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: cobylb + + +contains + + +subroutine cobylb(calcfc, iprint, maxfilt, maxfun, amat, bvec, ctol, cweight, eta1, eta2, ftarget, & + & gamma1, gamma2, rhobeg, rhoend, constr, f, x, nf, chist, conhist, cstrv, fhist, xhist, info, callback_fcn) +!--------------------------------------------------------------------------------------------------! +! This subroutine performs the actual calculations of COBYLA. +! +! IPRINT, MAXFILT, MAXFUN, MAXHIST, CTOL, CWEIGHT, ETA1, ETA2, FTARGET, GAMMA1, GAMMA2, RHOBEG, +! RHOEND, X, NF, F, XHIST, FHIST, CHIST, CONHIST, CSTRV, INFO and CALLBACK are identical to the corresponding +! arguments in subroutine COBYLA. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, HALF, TENTH, EPS, REALMAX, DEBUGGING, MIN_MAXFILT +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: evaluate_mod, only : evaluate, moderatec +use, non_intrinsic :: history_mod, only : savehist, rangehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, MAXTR_REACHED, SMALL_TR_RADIUS, DAMAGING_ROUNDING, CALLBACK_TERMINATE +use, non_intrinsic :: linalg_mod, only : inprod, matprod, norm, maximum +use, non_intrinsic :: message_mod, only : retmsg, rhomsg, fmsg +use, non_intrinsic :: pintrf_mod, only : OBJCON, CALLBACK +use, non_intrinsic :: ratio_mod, only : redrat +use, non_intrinsic :: redrho_mod, only : redrho +use, non_intrinsic :: selectx_mod, only : savefilt, selectx, isbetter + +! Solver-specific modules +use, non_intrinsic :: geometry_cobyla_mod, only : setdrop_tr, geostep +use, non_intrinsic :: initialize_cobyla_mod, only : initxfc, initfilt +use, non_intrinsic :: trustregion_cobyla_mod, only : trstlp, trrad +use, non_intrinsic :: update_cobyla_mod, only : updatexfc, updatepole + +implicit none + +! Inputs +procedure(OBJCON) :: calcfc ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfilt +integer(IK), intent(in) :: maxfun +real(RP), intent(in) :: amat(:, :) ! AMAT(N, M_LCON) +real(RP), intent(in) :: bvec(:) ! BVEC(M_LCON) +real(RP), intent(in) :: ctol +real(RP), intent(in) :: cweight +real(RP), intent(in) :: eta1 +real(RP), intent(in) :: eta2 +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: gamma1 +real(RP), intent(in) :: gamma2 +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: rhoend + +! In-outputs +! On entry, [X, F, CONSTR] = [X0, F(X0), CONSTR(X0)] +real(RP), intent(inout) :: constr(:) ! CONSTR(M) +real(RP), intent(inout) :: f +real(RP), intent(inout) :: x(:) ! X(N) + +! Outputs +integer(IK), intent(out) :: info +integer(IK), intent(out) :: nf +real(RP), intent(out) :: chist(:) ! CHIST(MAXCHIST) +real(RP), intent(out) :: conhist(:, :) ! CONHIST(M, MAXCONHIST) +real(RP), intent(out) :: cstrv +real(RP), intent(out) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out) :: xhist(:, :) ! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'COBYLA' +character(len=*), parameter :: srname = 'COBYLB' +integer(IK) :: j +integer(IK) :: jdrop_geo +integer(IK) :: jdrop_tr +integer(IK) :: kopt +integer(IK) :: m +integer(IK) :: m_lcon +integer(IK) :: maxchist +integer(IK) :: maxconhist +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxtr +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: nfilt +integer(IK) :: nhist +integer(IK) :: subinfo +integer(IK) :: tr +logical :: bad_trstep +logical :: adequate_geo +logical :: evaluated(size(x) + 1) +logical :: improve_geo +logical :: reduce_rho +logical :: shortd +logical :: terminate +logical :: trfail +logical :: ximproved +real(RP) :: A(size(x), size(constr)) ! A contains the approximate gradient for the constraints +real(RP) :: actrem +real(RP) :: cfilt(min(max(maxfilt, 1_IK), maxfun)) +real(RP) :: confilt(size(constr), size(cfilt)) +real(RP) :: conmat(size(constr), size(x) + 1) +real(RP) :: cpen ! Penalty parameter for constraint in merit function (PARMU in Powell's code) +real(RP) :: cval(size(x) + 1) +real(RP) :: d(size(x)) +real(RP) :: delbar +real(RP) :: delta +real(RP) :: distsq(size(x) + 1) +real(RP) :: dnorm +real(RP) :: ffilt(size(cfilt)) +real(RP) :: fval(size(x) + 1) +real(RP) :: g(size(x)) +real(RP) :: gamma3 +real(RP) :: prerec ! Predicted reduction in constraint violation +real(RP) :: preref ! Predicted reduction in objective Function +real(RP) :: prerem ! Predicted reduction in merit function +real(RP) :: ratio ! Reduction ratio: ACTREM/PREREM +real(RP) :: rho +real(RP) :: sim(size(x), size(x) + 1) +real(RP) :: simi(size(x), size(x)) +real(RP) :: xfilt(size(x), size(cfilt)) +! CPENMIN is the minimum of the penalty parameter CPEN for the L-infinity constraint violation in +! the merit function. Note that CPENMIN = 0 in Powell's implementation, which allows CPEN to be 0. +! Here, we take CPENMIN > 0 so that CPEN is always positive. This avoids the situation where PREREM +! becomes 0 when PREREF = 0 = CPEN. It brings two advantages as follows. +! 1. If the trust-region subproblem solver works correctly and the trust-region center is not +! optimal for the subproblem, then PREREM > 0 is guaranteed. This is because, in theory, PREREC >= 0 +! and MAX(PREREC, PREREF) > 0 , and the definition of CPEN in GETCPEN ensures that PREREM > 0. +! 2. There is no need to revise ACTREM and PREREM when CPEN = 0 and F = FVAL(N+1) as in lines +! 312--314 of Powell's cobylb.f code. Powell's code revises ACTREM to CVAL(N + 1) - CSTRV and PREREM +! to PREREC in this case, which is crucial for feasibility problems. +real(RP), parameter :: cpenmin = EPS + +! Sizes +m_lcon = int(size(bvec), kind(m_lcon)) +m = int(size(constr), kind(m)) +n = int(size(x), kind(n)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxconhist = int(size(conhist, 2), kind(maxconhist)) +maxchist = int(size(chist), kind(maxchist)) +maxhist = int(max(maxxhist, maxfhist, maxconhist, maxchist), kind(maxhist)) + +! Preconditions +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(m >= m_lcon .and. m_lcon >= 0, 'M >= M_LCON >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(maxfun >= n + 2, 'MAXFUN >= N + 2', srname) + call assert(rhobeg >= rhoend .and. rhoend > 0, 'RHOBEG >= RHOEND > 0', srname) + call assert(all(is_finite(x)), 'X is finite', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + call assert(ctol >= 0, 'CTOL >= 0', srname) + call assert(cweight >= 0, 'CWEIGHT >= 0', srname) + call assert(maxhist >= 0 .and. maxhist <= maxfun, '0 <= MAXHIST <= MAXFUN', srname) + call assert(size(amat, 1) == n .and. size(amat, 2) == size(bvec), 'SIZE(AMAT) == [N, SIZE(BVEC)]', srname) + call assert(maxfilt >= min(MIN_MAXFILT, maxfun) .and. maxfilt <= maxfun, & + & 'MIN(MIN_MAXFILT, MAXFUN) <= MAXFILT <= MAXFUN', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(size(conhist, 1) == m .and. maxconhist * (maxconhist - maxhist) == 0, & + & 'SIZE(CONHIST, 1) == M, SIZE(CONHIST, 2) == 0 or MAXHIST', srname) + call assert(maxchist * (maxchist - maxhist) == 0, 'SIZE(CHIST) == 0 or MAXHIST', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialize SIM, SIMI, FVAL, CONMAT, and CVAL, together with the history, NF, and EVALUATED. +! After the initialization, SIM(:, N+1) holds the vertex of the initial simplex with the smallest +! function value (regardless of the constraint violation), and SIM(:, 1:N) holds the displacements +! from the other vertices to SIM(:, N+1). FVAL, CONMAT, and CVAL hold the function values, +! constraint values, and constraint violations on the vertices in the order corresponding to SIM. +call initxfc(calcfc, iprint, maxfun, amat, bvec, constr, ctol, f, ftarget, rhobeg, x, nf, chist, & + & conhist, conmat, cval, fhist, fval, sim, simi, xhist, evaluated, subinfo) + +! Report the current best value, and check if user asks for early termination. +terminate = .false. +if (present(callback_fcn)) then + call callback_fcn(sim(:, n + 1), fval(n + 1), nf, 0_IK, cval(n + 1), conmat(m_lcon + 1:m, n + 1), terminate) + if (terminate) then + subinfo = CALLBACK_TERMINATE + end if +end if + +! Initialize the filter, including XFILT, FFILT, CONFILT, CFILT, and NFILT. +! N.B.: The filter is used only when selecting which iterate to return. It does not interfere with +! the iterations. COBYLA is NOT a filter method but a trust-region method based on an L-infinity +! merit function. Powell's implementation does not use a filter to select the iterate, possibly +! returning a suboptimal iterate. +call initfilt(conmat, ctol, cweight, cval, fval, sim, evaluated, nfilt, cfilt, confilt, ffilt, xfilt) + +! Check whether to return due to abnormal cases that may occur during the initialization. +if (subinfo /= INFO_DFT) then + info = subinfo + ! Return the best calculated values of the variables. + ! N.B. SELECTX and FINDPOLE choose X by different standards. One cannot replace the other. + kopt = selectx(ffilt(1:nfilt), cfilt(1:nfilt), cweight, ctol) + x = xfilt(:, kopt) + f = ffilt(kopt) + constr = confilt(:, kopt) + cstrv = cfilt(kopt) + ! Arrange CHIST, CONHIST, FHIST, and XHIST so that they are in the chronological order. + call rangehist(nf, xhist, fhist, chist, conhist) + ! Print a return message according to IPRINT. + call retmsg(solver, info, iprint, nf, f, x, cstrv, constr) + ! Postconditions + if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(size(conhist, 1) == m .and. size(conhist, 2) == maxconhist, & + & 'SIZE(CONHIST) == [M, MAXCONHIST]', srname) + call assert(.not. any(is_nan(conhist(:, 1:min(nf, maxconhist))) .or. & + & is_posinf(conhist(:, 1:min(nf, maxconhist)))), 'CONHIST does not contain NaN/+Inf', srname) + call assert(size(chist) == maxchist, 'SIZE(CHIST) == MAXCHIST', srname) + call assert(.not. any(chist(1:min(nf, maxchist)) < 0 .or. is_nan(chist(1:min(nf, maxchist))) & + & .or. is_posinf(chist(1:min(nf, maxchist)))), 'CHIST does not contain negative values or NaN/+Inf', srname) + nhist = minval([nf, maxfhist, maxchist]) + call assert(.not. any(isbetter(fhist(1:nhist), chist(1:nhist), f, cstrv, ctol)), & + & 'No point in the history is better than X', srname) + end if + return +end if + +! Set some more initial values. +! We must initialize ACTREM and PREREM. Otherwise, when SHORTD = TRUE, compilers may raise a +! run-time error that they are undefined. But their values will not be used: when SHORTD = FALSE, +! they will be overwritten; when SHORTD = TRUE, the values are used only in BAD_TRSTEP, which is +! TRUE regardless of ACTREM or PREREM. Similar for PREREC, PREREF, PREREM, RATIO, and JDROP_TR. +! No need to initialize SHORTD unless MAXTR < 1, but some compilers may complain if we do not do it. +! Our initialization of CPEN differs from Powell's in two ways. First, we use the ratio defined in +! (13) of Powell's COBYLA paper to initialize CPEN. Second, we impose CPEN >= CPENMIN > 0. Powell's +! code simply initializes CPEN to 0. +rho = rhobeg +delta = rhobeg +cpen = max(cpenmin, min(1.0E3_RP, fcratio(conmat, fval))) ! Powell's code: CPEN = ZERO +prerec = -REALMAX +preref = -REALMAX +prerem = -REALMAX +actrem = -REALMAX +shortd = .false. +trfail = .false. +ratio = -ONE +jdrop_tr = 0 +jdrop_geo = 0 + +! If DELTA <= GAMMA3*RHO after an update, we set DELTA to RHO. GAMMA3 must be less than GAMMA2. The +! reason is as follows. Imagine a very successful step with DENORM = the un-updated DELTA = RHO. +! Then TRRAD will update DELTA to GAMMA2*RHO. If GAMMA3 >= GAMMA2, then DELTA will be reset to RHO, +! which is not reasonable as D is very successful. See paragraph two of Sec. 5.2.5 in +! T. M. Ragonneau's thesis: "Model-Based Derivative-Free Optimization Methods and Software". +! According to test on 20230613, for COBYLA, this Powellful updating scheme of DELTA works slightly +! better than setting directly DELTA = MAX(NEW_DELTA, RHO). +gamma3 = max(ONE, min(0.75_RP * gamma2, 1.5_RP)) + +! MAXTR is the maximal number of trust-region iterations. Here, we set it to HUGE(MAXTR) - 1 so that +! the algorithm will not terminate due to MAXTR. However, this may not be allowed in other languages +! such as MATLAB. In that case, we can set MAXTR to 10*MAXFUN, which is unlikely to reach because +! each trust-region iteration takes 1 or 2 function evaluations unless the trust-region step is short +! or fails to reduce the trust-region model but the geometry step is not invoked. +! N.B.: Do NOT set MAXTR to HUGE(MAXTR), as it may cause overflow and infinite cycling in the DO +! loop. See +! https://fortran-lang.discourse.group/t/loop-variable-reaching-integer-huge-causes-infinite-loop +! https://fortran-lang.discourse.group/t/loops-dont-behave-like-they-should +maxtr = huge(maxtr) - 1_IK !!MATLAB: maxtr = 10 * maxfun; +info = MAXTR_REACHED + +! Begin the iterative procedure. +! After solving a trust-region subproblem, we use three boolean variables to control the workflow. +! SHORTD - Is the trust-region trial step too short to invoke a function evaluation? +! IMPROVE_GEO - Will we improve the model after the trust-region iteration? If yes, a geometry step +! will be taken, corresponding to the "Branch (Delta)" in the COBYLA paper. +! REDUCE_RHO - Will we reduce rho after the trust-region iteration? +! COBYLA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. +do tr = 1, maxtr + ! Increase the penalty parameter CPEN, if needed, so that PREREM = PREREF + CPEN * PREREC > 0. + ! This is the first (out of two) update of CPEN, where CPEN increases or remains the same. + ! N.B.: CPEN and the merit function PHI = FVAL + CPEN*CVAL are used at three places only. + ! 1. In FINDPOLE/UPDATEPOLE, deciding the optimal vertex of the current simplex. + ! 2. After the trust-region trial step, calculating the reduction radio. + ! 3. In GEOSTEP, deciding the direction of the geometry step. + ! They do not appear explicitly in the trust-region subproblem, though the trust-region center + ! (i.e., the current optimal vertex) is defined by them. + cpen = getcpen(amat, bvec, conmat, cpen, cval, delta, fval, rho, sim, simi) + + ! Switch the best vertex of the current simplex to SIM(:, N + 1). + call updatepole(cpen, conmat, cval, fval, sim, simi, subinfo) + ! Check whether to exit due to damaging rounding in UPDATEPOLE. + if (subinfo == DAMAGING_ROUNDING) then + info = subinfo + exit ! Better action to take? Geometry step, or simply continue? + end if + + ! Does the interpolation set have adequate geometry? It affects IMPROVE_GEO and REDUCE_RHO. + adequate_geo = all(sum(sim(:, 1:n)**2, dim=1) <= 4.0_RP * delta**2) + + ! Calculate the linear approximations to the objective and constraint functions. + ! N.B.: TRSTLP accesses A mostly by columns, so it is more reasonable to save A instead of A^T. + ! Zaikun 2023108: According to a test on 2023108, calculating G and A(:, M_LCON+1:M) by solving + ! the linear systems SIM^T*G = FVAL(1:N)-FVAL(N+1) and SIM^T*A = CONMAT(:, 1:N)-CONMAT(:, N+1) + ! does not seem to improve or worsen the performance of COBYLA in terms of the number of function + ! evaluations. The system was solved by SOLVE in LINALG_MOD based on a QR factorization of SIM + ! (not necessarily a good algorithm). No preconditioning or scaling was used. + g = matprod(fval(1:n) - fval(n + 1), simi) + A(:, 1:m_lcon) = amat + A(:, m_lcon + 1:m) = transpose(matprod(conmat(m_lcon + 1:m, 1:n) - spread(conmat(m_lcon + 1:m, n + 1), dim=2, ncopies=n), simi)) + !!MATLAB: A(:, m_lcon+1:m) = simi'*(conmat(m_lcon+1:m, 1:n) - conmat(m_lcon+1:m, n+1))' % Implicit expansion for subtraction + + ! Calculate the trust-region trial step D. Note that D does NOT depend on CPEN. + d = trstlp(A, -conmat(:, n + 1), delta, g) + dnorm = min(delta, norm(d)) + + ! Is the trust-region trial step short? Note that we compare DNORM with RHO, not DELTA. + ! Powell's code essentially defines SHORTD by SHORTD = (DNORM < HALF * RHO). In our tests, + ! TENTH seems to work better than HALF or QUART, especially for linearly constrained problems. + ! Note that LINCOA has a slightly more sophisticated way of defining SHORTD, taking into account + ! whether D causes a change to the active set. Should we try the same here? + shortd = (dnorm <= TENTH * rho) ! `<=` works better than `<` in case of underflow. + + ! Predict the change to F (PREREF) and to the constraint violation (PREREC) due to D. + ! We have the following in precise arithmetic. They may fail to hold due to rounding errors. + ! 1. PREREC is the reduction of the L-infinity violation of the linearized constraints achieved + ! by D. It is nonnegative in theory; it is 0 iff CONMAT(1:M, N+1) <= 0, namely the trust-region + ! center satisfies the constraints. + ! 2. PREREF may be negative or 0, but it should be positive when PREREC = 0 and SHORTD is FALSE. + ! 3. Due to 2, in theory, MAXIMUM([PREREC, PREREF]) > 0 if SHORTD is FALSE. + preref = -inprod(d, g) ! Can be negative. + prerec = cval(n + 1) - maximum([ZERO, conmat(:, n + 1) + matprod(d, A)]) + + ! Evaluate PREREM, which is the predicted reduction in the merit function. + ! In theory, PREREM >= 0 and it is 0 iff CPEN = 0 = PREREF. This may not be true numerically. + prerem = preref + cpen * prerec + trfail = (.not. prerem > 1.0E-6 * min(cpen, ONE) * rho) ! PREREM is tiny/negative or NaN. + + if (shortd .or. trfail) then + ! Reduce DELTA if D is short or D fails to render PREREM > 0. The latter can happen due to + ! rounding errors. This seems important for performance. + delta = TENTH * delta + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + else + ! Calculate the next value of the objective and constraint functions. + ! If X is close to one of the points in the interpolation set, then we do not evaluate the + ! objective and constraints at X, assuming them to have the values at the closest point. + ! N.B.: If this happens, do NOT include X into the filter, as F and CONSTR are inaccurate. + x = sim(:, n + 1) + d + distsq(n + 1) = sum((x - sim(:, n + 1))**2) + distsq(1:n) = [(sum((x - (sim(:, n + 1) + sim(:, j)))**2), j=1, n)] ! Implied do-loop + !!MATLAB: distsq(1:n) = sum((x - (sim(:,1:n) + sim(:, n+1)))**2, 1) % Implicit expansion + j = int(minloc(distsq, dim=1), kind(j)) + if (distsq(j) <= (1.0E-4 * rhoend)**2) then + f = fval(j) + constr = conmat(:, j) + cstrv = cval(j) + else + ! Evaluate the objective and constraints at X, taking care of possible Inf/NaN values. + constr(1:m_lcon) = moderatec(matprod(x, amat) - bvec) ! Linear constraints + call evaluate(calcfc, x, f, constr(m_lcon + 1:m)) ! Nonlinear constraints + ! Note that EVALUATE moderates the nonlinear constraint values. Thus we also moderate the + ! linear constraint values here to make CSTRV consistent. + cstrv = maximum([ZERO, constr]) + nf = nf + 1_IK + ! Save X, F, CONSTR, CSTRV into the history. + call savehist(nf, x, xhist, f, fhist, cstrv, chist, constr, conhist) + ! Save X, F, CONSTR, CSTRV into the filter. + call savefilt(cstrv, ctol, cweight, f, x, nfilt, cfilt, ffilt, xfilt, constr, confilt) + end if + + ! Print a message about the function/constraint evaluation according to IPRINT. + call fmsg(solver, 'Trust region', iprint, nf, delta, f, x, cstrv, constr) + + ! Evaluate ACTREM, which is the actual reduction in the merit function. + actrem = (fval(n + 1) + cpen * cval(n + 1)) - (f + cpen * cstrv) + + ! Calculate the reduction ratio by REDRAT, which handles Inf/NaN carefully. + ratio = redrat(actrem, prerem, eta1) + + ! Update DELTA. After this, DELTA < DNORM may hold. + ! N.B.: 1. Powell's code uses RHO as the trust-region radius and updates it as follows. + ! Reduce RHO to GAMMA1*RHO if ADEQUATE_GEO is TRUE and either SHORTD is TRUE or RATIO < ETA1, + ! and then revise RHO to RHOEND if its new value is not more than GAMMA3*RHOEND; RHO remains + ! unchanged in all other cases; in particular, RHO is never increased. + ! 2. Our implementation uses DELTA as the trust-region radius, while using RHO as a lower + ! bound for DELTA. DELTA is updated in a way that is typical for trust-region methods, and + ! it is revised to RHO if its new value is not more than GAMMA3*RHO. RHO reflects the current + ! resolution of the algorithm; its update is essentially the same as the update of RHO in + ! Powell's code (see the definition of REDUCE_RHO below). Our implementation aligns with + ! UOBYQA/NEWUOA/BOBYQA/LINCOA and improves the performance of COBYLA. + ! 3. The same as Powell's code, we do not reduce RHO unless ADEQUATE_GEO is TRUE. This is + ! also how Powell updated RHO in UOBYQA/NEWUOA/BOBYQA/LINCOA. What about we also use + ! ADEQUATE_GEO == TRUE as a prerequisite for reducing DELTA? The argument would be that the + ! bad (small) value of RATIO may be because of a bad geometry (and hence a bad model) rather + ! than an improperly large DELTA, and it might be good to try improving the geometry first + ! without reducing DELTA. However, according to a test on 20230206, it does not improve the + ! performance if we skip the update of DELTA when ADEQUATE_GEO is FALSE and RATIO < 0.1. + ! Therefore, we choose to update DELTA without checking ADEQUATE_GEO. + delta = trrad(delta, dnorm, eta1, eta2, gamma1, gamma2, ratio) + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + + ! Is the newly generated X better than current best point? + ximproved = (actrem > 0) ! If ACTREM is NaN, then XIMPROVED should & will be FALSE. + + ! Set JDROP_TR to the index of the vertex to be replaced with X. JDROP_TR = 0 means there + ! is no good point to replace, and X will not be included into the simplex; in this case, + ! the geometry of the simplex likely needs improvement, which will be handled below. + jdrop_tr = setdrop_tr(ximproved, d, delta, rho, sim, simi) + + ! Update SIM, SIMI, FVAL, CONMAT, and CVAL so that SIM(:, JDROP_TR) is replaced with D. + ! UPDATEXFC does nothing if JDROP_TR == 0, as the algorithm decides to discard X. + call updatexfc(jdrop_tr, constr, cpen, cstrv, d, f, conmat, cval, fval, sim, simi, subinfo) + ! Check whether to exit due to damaging rounding in UPDATEXFC. + if (subinfo == DAMAGING_ROUNDING) then + info = subinfo + exit ! Better action to take? Geometry step, or a RESCUE as in BOBYQA? + end if + + ! Check whether to exit due to MAXFUN, FTARGET, etc. + subinfo = checkexit(maxfun, nf, cstrv, ctol, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + end if ! End of IF (SHORTD .OR. TRFAIL). The normal trust-region calculation ends. + + + !----------------------------------------------------------------------------------------------! + ! Before the next trust-region iteration, we possibly improve the geometry of simplex or reduce + ! RHO according to IMPROVE_GEO and REDUCE_RHO. Now we decide these indicators. + ! N.B.: We must ensure that the algorithm does not set IMPROVE_GEO = TRUE at infinitely many + ! consecutive iterations without moving SIM(:, N+1) or reducing RHO. Otherwise, the algorithm + ! will get stuck in repetitive invocations of GEOSTEP. This is ensured by the following facts. + ! 1. If an iteration sets IMPROVE_GEO = TRUE, it must also reduce DELTA or set DELTA to RHO. + ! 2. If SIM(:, N+1) and RHO remains unchanged, then ADEQUATE_GEO will become TRUE after at + ! most N invocations of GEOSTEP. + + ! BAD_TRSTEP: Is the last trust-region step bad? + bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. jdrop_tr == 0) + ! IMPROVE_GEO: Should we take a geometry step to improve the geometry of the interpolation set? + improve_geo = (bad_trstep .and. .not. adequate_geo) + ! REDUCE_RHO: Should we enhance the resolution by reducing RHO? + reduce_rho = (bad_trstep .and. adequate_geo .and. max(delta, dnorm) <= rho) + + ! COBYLA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. + ! !call assert(.not. (improve_geo .and. reduce_rho), 'IMPROVE_GEO or REDUCE_RHO are not both TRUE', srname) + + ! If SHORTD or TRFAIL is TRUE, then either IMPROVE_GEO or REDUCE_RHO is TRUE unless ADEQUATE_GEO + ! is TRUE and MAX(DELTA, DNORM) > RHO. + ! !call assert((.not. (shortd .or. trfail)) .or. (improve_geo .or. reduce_rho .or. & + ! ! & (adequate_geo .and. max(delta, dnorm) > rho)), 'If SHORTD or TRFAIL is TRUE, then & + ! ! & either IMPROVE_GEO or REDUCE_RHO is TRUE unless ADEQUATE_GEO is TRUE and MAX(DELTA, DNORM) > RHO', srname) + !----------------------------------------------------------------------------------------------! + + ! Comments on BAD_TRSTEP: + ! 1. Powell's definition of BAD_TRSTEP is as follows. The one used above seems to work better, + ! especially for linearly constrained problems due to the factor TENTH (= ETA1). + ! !bad_trstep = (shortd .or. actrem <= 0 .or. actrem < TENTH * prerem .or. jdrop_tr == 0) + ! Besides, Powell did not check PREREM > 0 in BAD_TRSTEP, which is reasonable to do but has + ! little impact upon the performance. + ! 2. NEWUOA/BOBYQA/LINCOA would define BAD_TRSTEP, IMPROVE_GEO, and REDUCE_RHO as follows. Two + ! different thresholds are used in BAD_TRSTEP. It outperforms Powell's version. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= eta1 .or. jdrop_tr == 0) + ! !improve_geo = bad_trstep .and. .not. adequate_geo + ! !bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. jdrop_tr == 0) + ! !reduce_rho = bad_trstep .and. adequate_geo .and. max(delta, dnorm) <= rho + ! 3. Theoretically, JDROP_TR > 0 when ACTREM > 0 (guaranteed by RATIO > 0). However, in Powell's + ! implementation, JDROP_TR may be 0 even RATIO > 0 due to NaN. The modernized code has rectified + ! this in the function SETDROP_TR. After this rectification, we can indeed simplify the + ! definition of BAD_TRSTEP by removing the condition JDROP_TR == 0. We retain it for robustness. + + ! Comments on REDUCE_RHO: + ! When SHORTD is TRUE, UOBYQA/NEWUOA/BOBYQA/LINCOA all set REDUCE_RHO to TRUE if the recent + ! models are sufficiently accurate according to certain criteria. See the paragraph around (37) + ! in the UOBYQA paper and the discussions about Box 14 in the NEWUOA paper. This strategy is + ! crucial for the performance of the solvers. However, as of 20221111, we have not managed to + ! make it work in COBYLA. As in NEWUOA, we recorded the errors of the recent models, and set + ! REDUCE_RHO to true if they are small (e.g., ALL(ABS(MODERR_REC) <= 0.1 * MAXVAL(ABS(A))*RHO) or + ! ALL(ABS(MODERR_REC) <= RHO**2)) when SHORTD is TRUE. It made little impact on the performance. + + + ! Since COBYLA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously, the following + ! two blocks are exchangeable: IF (IMPROVE_GEO) ... END IF and IF (REDUCE_RHO) ... END IF. + + ! Improve the geometry of the simplex by removing a point and adding a new one. + ! If the current interpolation set has adequate geometry, then we skip the geometry step. + ! The code has a small difference from Powell's original code here: If the current geometry + ! is adequate, then we will continue with a new trust-region iteration; however, at the + ! beginning of the iteration, CPEN may be updated, which may alter the pole point SIM(:, N+1) + ! by UPDATEPOLE; the quality of the interpolation point depends on SIM(:, N + 1), meaning + ! that the same interpolation set may have good or bad geometry with respect to different + ! "poles"; if the geometry turns out bad with the new pole, the original COBYLA code will + ! take a geometry step, yet our code here will NOT do it but continue to take a trust-region + ! step. The argument is this: even if the geometry step is not skipped in the first place, the + ! geometry may turn out bad again after the pole is altered due to an update to CPEN; should + ! we take another geometry step in that case? If no, why should we do it here? Indeed, this + ! distinction makes no practical difference for CUTEst problems with at most 100 variables + ! and 5000 constraints, while the algorithm framework is simplified. + if (improve_geo .and. .not. all(sum(sim(:, 1:n)**2, dim=1) <= 4.0_RP * delta**2)) then + ! Before the geometry step, UPDATEPOLE has been called either implicitly by UPDATEXFC or + ! explicitly after CPEN is updated, so that SIM(:, N + 1) is the optimal vertex. + + ! Decide a vertex to drop from the simplex. It will be replaced with SIM(:, N + 1) + D to + ! improve the geometry of the simplex. + ! N.B.: 1. COBYLA never sets JDROP_GEO = N + 1. + ! 2. The following JDROP_GEO comes from UOBYQA/NEWUOA/BOBYQA/LINCOA. + ! 3. In Powell's original algorithm, the geometry of the simplex is considered acceptable + ! iff the distance between any vertex and the pole is at most 2.1*DELTA, and the distance + ! between any vertex and the opposite face of the simplex is at least 0.25*DELTA, as + ! specified in (14) of the COBYLA paper. Correspondingly, JDROP_GEO is set to the index of + ! the vertex with the largest distance to the pole provided that the distance is larger than + ! 2.1*DELTA, or the vertex with the smallest distance to the opposite face of the simplex, + ! in which case the distance must be less than 0.25*DELTA, as the current simplex does not + ! have acceptable geometry (see (15)--(16) of the COBYLA paper). Once JDROP_GEO is set, the + ! algorithm replaces SIM(:, JDROP_GEO) with D specified in (17) of the COBYLA paper, which + ! is orthogonal to the face opposite to SIM(:, JDROP_GEO) and has a length of 0.5*DELTA, + ! intending to improve the geometry of the simplex as per (14). + ! 4. Powell's geometry-improving procedure outlined above has an intrinsic flaw: it may lead + ! to infinite cycling, as was observed in a test on 20240320. In this test, the geometry- + ! improving point introduced in the previous iteration was replaced with the trust-region + ! trial point in the current iteration, which was then replaced with the same geometry- + ! improving point in the next iteration, and so on. In this process, the simplex alternated + ! between two configurations, neither of which had acceptable geometry. Thus RHO was never + ! reduced, leading to infinite cycling. (N.B.: Our implementation uses DELTA as the trust + ! region radius, with RHO being its lower bound. When the infinite cycling occurred in this + ! test, DELTA = RHO and it could not be reduced due to the requirement that DELTA >= RHO.) + jdrop_geo = int(maxloc(sum(sim(:, 1:n)**2, dim=1), dim=1), kind(jdrop_geo)) + + ! Calculate the geometry step D. + delbar = HALF * delta + d = geostep(jdrop_geo, amat, bvec, conmat, cpen, cval, delbar, fval, simi) + + ! Calculate the next value of the objective and constraint functions. + ! If X is close to one of the points in the interpolation set, then we do not evaluate the + ! objective and constraints at X, assuming them to have the values at the closest point. + ! N.B.: + ! 1. If this happens, do NOT include X into the filter, as F and CONSTR are inaccurate. + ! 2. In precise arithmetic, the geometry improving step ensures that the distance between X + ! and any interpolation point is at least DELBAR, yet X may be close to them due to + ! rounding. In an experiment with single precision on 20240317, X = SIM(:, N+1) occurred. + x = sim(:, n + 1) + d + distsq(n + 1) = sum((x - sim(:, n + 1))**2) + distsq(1:n) = [(sum((x - (sim(:, n + 1) + sim(:, j)))**2), j=1, n)] ! Implied do-loop + !!MATLAB: distsq(1:n) = sum((x - (sim(:,1:n) + sim(:, n+1)))**2, 1) % Implicit expansion + j = int(minloc(distsq, dim=1), kind(j)) + if (distsq(j) <= (1.0E-4 * rhoend)**2) then + f = fval(j) + constr = conmat(:, j) + cstrv = cval(j) + else + ! Evaluate the objective and constraints at X, taking care of possible Inf/NaN values. + constr(1:m_lcon) = moderatec(matprod(x, amat) - bvec) ! Linear constraints + call evaluate(calcfc, x, f, constr(m_lcon + 1:m)) ! Nonlinear constraints + ! Note that EVALUATE moderates the nonlinear constraint values. Thus we also moderate the + ! linear constraint values here to make CSTRV consistent. + cstrv = maximum([ZERO, constr]) + nf = nf + 1_IK + ! Save X, F, CONSTR, CSTRV into the history. + call savehist(nf, x, xhist, f, fhist, cstrv, chist, constr, conhist) + ! Save X, F, CONSTR, CSTRV into the filter. + call savefilt(cstrv, ctol, cweight, f, x, nfilt, cfilt, ffilt, xfilt, constr, confilt) + end if + + ! Print a message about the function/constraint evaluation according to IPRINT. + call fmsg(solver, 'Geometry', iprint, nf, delta, f, x, cstrv, constr) + ! Update SIM, SIMI, FVAL, CONMAT, and CVAL so that SIM(:, JDROP_GEO) is replaced with D. + call updatexfc(jdrop_geo, constr, cpen, cstrv, d, f, conmat, cval, fval, sim, simi, subinfo) + ! Check whether to exit due to damaging rounding in UPDATEXFC. + if (subinfo == DAMAGING_ROUNDING) then + info = subinfo + exit ! Better action to take? Geometry step, or simply continue? + end if + + ! Check whether to exit due to MAXFUN, FTARGET, etc. + subinfo = checkexit(maxfun, nf, cstrv, ctol, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + end if ! End of IF (IMPROVE_GEO). The procedure of improving geometry ends. + + ! The calculations with the current RHO are complete. Enhance the resolution of the algorithm + ! by reducing RHO; update DELTA and CPEN at the same time. + if (reduce_rho) then + if (rho <= rhoend) then + info = SMALL_TR_RADIUS + exit + end if + delta = max(HALF * rho, redrho(rho, rhoend)) + rho = redrho(rho, rhoend) + ! The second (out of two) update of CPEN, where CPEN decreases or remains the same. + ! Powell's code: CPEN = MIN(CPEN, FCRATIO(FVAL, CONMAT)), which may set CPEN to 0. + cpen = max(cpenmin, min(cpen, fcratio(conmat, fval))) + ! Print a message about the reduction of RHO according to IPRINT. + call rhomsg(solver, iprint, nf, delta, fval(n + 1), rho, sim(:, n + 1), cval(n + 1), conmat(:, n + 1), cpen) + ! Switch the best vertex of the current simplex to SIM(:, N + 1). + call updatepole(cpen, conmat, cval, fval, sim, simi, subinfo) + ! Check whether to exit due to damaging rounding in UPDATEPOLE. + if (subinfo == DAMAGING_ROUNDING) then + info = subinfo + exit ! Better action to take? Geometry step, or simply continue? + end if + end if ! End of IF (REDUCE_RHO). The procedure of reducing RHO ends. + + ! Report the current best value, and check if user asks for early termination. + if (present(callback_fcn)) then + call callback_fcn(sim(:, n + 1), fval(n + 1), nf, tr, cval(n + 1), conmat(m_lcon + 1:m, n + 1), terminate) + if (terminate) then + info = CALLBACK_TERMINATE + exit + end if + end if + +end do ! End of DO TR = 1, MAXTR. The iterative procedure ends. + +! Return from the calculation, after trying the last trust-region step if it has not been tried yet. +! Ensure that D has not been updated after SHORTD == TRUE occurred, or the code below is incorrect. +x = sim(:, n + 1) + d +if (info == SMALL_TR_RADIUS .and. shortd .and. norm(x - sim(:, n + 1)) > 1.0E-3_RP * rhoend .and. nf < maxfun) then + constr(1:m_lcon) = moderatec(matprod(x, amat) - bvec) ! Linear constraints + call evaluate(calcfc, x, f, constr(m_lcon + 1:m)) ! Nonlinear constraints + ! Note that EVALUATE moderates the nonlinear constraint values. Thus we also moderate the linear + ! constraint values here to make CSTRV consistent. + cstrv = maximum([ZERO, constr]) + nf = nf + 1_IK + ! Save X, F, CONSTR, CSTRV into the history. + call savehist(nf, x, xhist, f, fhist, cstrv, chist, constr, conhist) + ! Save X, F, CONSTR, CSTRV into the filter. + call savefilt(cstrv, ctol, cweight, f, x, nfilt, cfilt, ffilt, xfilt, constr, confilt) + ! Print a message about the function/constraint evaluation according to IPRINT. + ! Zaikun 20230512: DELTA has been updated. RHO is only indicative here. TO BE IMPROVED. + call fmsg(solver, 'Trust region', iprint, nf, rho, f, x, cstrv, constr) +end if + +! Return the best calculated values of the variables. +! N.B. SELECTX and FINDPOLE choose X by different standards. One cannot replace the other. +kopt = selectx(ffilt(1:nfilt), cfilt(1:nfilt), max(cpen, cweight), ctol) +x = xfilt(:, kopt) +f = ffilt(kopt) +constr = confilt(:, kopt) +cstrv = cfilt(kopt) + +! Arrange CHIST, CONHIST, FHIST, and XHIST so that they are in the chronological order. +call rangehist(nf, xhist, fhist, chist, conhist) + +! Print a return message according to IPRINT. +call retmsg(solver, info, iprint, nf, f, x, cstrv, constr) +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(size(conhist, 1) == m .and. size(conhist, 2) == maxconhist, & + & 'SIZE(CONHIST) == [M, MAXCONHIST]', srname) + call assert(.not. any(is_nan(conhist(:, 1:min(nf, maxconhist))) .or. & + & is_posinf(conhist(:, 1:min(nf, maxconhist)))), 'CONHIST does not contain NaN/+Inf', srname) + call assert(size(chist) == maxchist, 'SIZE(CHIST) == MAXCHIST', srname) + call assert(.not. any(chist(1:min(nf, maxchist)) < 0 .or. is_nan(chist(1:min(nf, maxchist))) & + & .or. is_posinf(chist(1:min(nf, maxchist)))), 'CHIST does not contain negative values or NaN/+Inf', srname) + nhist = minval([nf, maxfhist, maxchist]) + call assert(.not. any(isbetter(fhist(1:nhist), chist(1:nhist), f, cstrv, ctol)), & + & 'No point in the history is better than X', srname) +end if + +end subroutine cobylb + + +function getcpen(amat, bvec, conmat_in, cpen_in, cval_in, delta, fval_in, rho, sim_in, simi_in) result(cpen) +!--------------------------------------------------------------------------------------------------! +! This function gets the penalty parameter CPEN so that PREREM = PREREF + CPEN * PREREC > 0. +! See the discussions around equation (9) of the COBYLA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_posinf, is_nan +use, non_intrinsic :: infos_mod, only : INFO_DFT, DAMAGING_ROUNDING +use, non_intrinsic :: linalg_mod, only : matprod, inprod, isinv, maximum + +! Solver-specific modules +use, non_intrinsic :: trustregion_cobyla_mod, only : trstlp +use, non_intrinsic :: update_cobyla_mod, only : findpole, updatepole + +implicit none + +! Inputs +real(RP), intent(in) :: amat(:, :) +real(RP), intent(in) :: bvec(:) +real(RP), intent(in) :: conmat_in(:, :) +real(RP), intent(in) :: cpen_in +real(RP), intent(in) :: cval_in(:) +real(RP), intent(in) :: delta +real(RP), intent(in) :: fval_in(:) +real(RP), intent(in) :: rho +real(RP), intent(in) :: sim_in(:, :) +real(RP), intent(in) :: simi_in(:, :) + +! Outputs +real(RP) :: cpen + +! Local variables +character(len=*), parameter :: srname = 'getcpen' +integer(IK) :: info +integer(IK) :: iter +integer(IK) :: m +integer(IK) :: m_lcon +integer(IK) :: n +real(RP) :: A(size(sim_in, 1), size(conmat_in, 1)) +real(RP) :: conmat(size(conmat_in, 1), size(conmat_in, 2)) +real(RP) :: cval(size(cval_in)) +real(RP) :: d(size(sim_in, 1)) +real(RP) :: fval(size(fval_in)) +real(RP) :: g(size(sim_in, 1)) +real(RP) :: prerec +real(RP) :: preref +real(RP) :: sim(size(sim_in, 1), size(sim_in, 2)) +real(RP) :: simi(size(simi_in, 1), size(simi_in, 2)) +real(RP), parameter :: itol = ONE + +! Sizes +m_lcon = int(size(bvec), kind(m_lcon)) +m = int(size(conmat, 1), kind(m)) +n = int(size(sim, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(size(amat, 1) == n .and. size(amat, 2) == size(bvec), 'SIZE(AMAT) == [N, SIZE(BVEC)]', srname) + call assert(cpen_in > 0, 'CPEN > 0', srname) + call assert(size(conmat_in, 1) == m .and. size(conmat_in, 2) == n + 1, 'SIZE(CONMAT) = [M, N+1]', srname) + call assert(.not. any(is_nan(conmat_in) .or. is_posinf(conmat_in)), 'CONMAT does not contain NaN/+Inf', srname) + call assert(size(cval_in) == n + 1 .and. .not. any(cval_in < 0 .or. is_nan(cval_in) .or. is_posinf(cval_in)), & + & 'SIZE(CVAL) == N+1 and CVAL does not contain negative values or NaN/+Inf', srname) + call assert(size(fval_in) == n + 1 .and. .not. any(is_nan(fval_in) .or. is_posinf(fval_in)), & + & 'SIZE(FVAL) == N+1 and FVAL does not contain NaN/+Inf', srname) + call assert(size(sim_in, 1) == n .and. size(sim_in, 2) == n + 1, 'SIZE(SIM) == [N, N+1]', srname) + call assert(all(is_finite(sim_in)), 'SIM is finite', srname) + call assert(all(sum(abs(sim_in(:, 1:n)), dim=1) > 0), 'SIM(:, 1:N) has no zero column', srname) + call assert(size(simi_in, 1) == n .and. size(simi_in, 2) == n, 'SIZE(SIMI) == [N, N]', srname) + call assert(all(is_finite(simi_in)), 'SIMI is finite', srname) + call assert(isinv(sim_in(:, 1:n), simi_in, itol), 'SIMI = SIM(:, 1:N)^{-1}', srname) + call assert(delta >= rho .and. rho > 0, 'DELTA >= RHO > 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Copy the inputs. +conmat = conmat_in +cpen = cpen_in +cval = cval_in +fval = fval_in +sim = sim_in +simi = simi_in + +! Initialize INFO, PREREF, and PREREC, which are needed in the postconditions. +info = INFO_DFT +preref = ZERO +prerec = ZERO + +! Increase CPEN if necessary to ensure PREREM > 0. Branch back for the next loop if this change +! alters the optimal vertex of the current simplex. Note the following. +! 1. In each loop, CPEN is changed only if PREREC > 0 > PREREF, in which case PREREM is guaranteed +! positive after the update. Note that PREREC >= 0 and MAX(PREREC, PREREF) > 0 in theory. If this +! holds numerically as well, then CPEN is not changed only if PREREC = 0 or PREREF >= 0, in which +! case PREREM is currently positive, explaining why CPEN needs no update. +! 2. Even without an upper bound for the loop counter, the loop can occur at most N+1 times. This is +! because the update of CPEN does not decrease CPEN, and hence it can make vertex J (J <= N) become +! the new optimal vertex only if CVAL(J) is less than CVAL(N+1), which can happen at most N times. +! See the paragraph below (9) in the COBYLA paper. After the "correct" optimal vertex is found, +! one more loop is needed to calculate CPEN, and hence the loop can occur at most N+1 times. +do iter = 1, n + 1_IK + ! Switch the best vertex of the current simplex to SIM(:, N + 1). + call updatepole(cpen, conmat, cval, fval, sim, simi, info) + ! Check whether to exit due to damaging rounding in UPDATEPOLE. + if (info == DAMAGING_ROUNDING) then + exit + end if + + ! Calculate the linear approximations to the objective and constraint functions. + g = matprod(fval(1:n) - fval(n + 1), simi) + A(:, 1:m_lcon) = amat + A(:, m_lcon + 1:m) = transpose(matprod(conmat(m_lcon + 1:m, 1:n) - spread(conmat(m_lcon + 1:m, n + 1), dim=2, ncopies=n), simi)) + !!MATLAB: A(:, m_lcon+1:m) = simi'*(conmat(m_lcon+1:m, 1:n) - conmat(m_lcon+1:m, n+1))' % Implicit expansion for subtraction + + ! Calculate the trust-region trial step D. Note that D does NOT depend on CPEN. + d = trstlp(A, -conmat(:, n + 1), delta, g) + + ! Predict the change to F (PREREF) and to the constraint violation (PREREC) due to D. + preref = -inprod(d, g) ! Can be negative. + prerec = cval(n + 1) - maximum([ZERO, conmat(:, n + 1) + matprod(d, A)]) + + if (.not. (prerec > 0 .and. preref < 0)) then ! PREREC <= 0 or PREREF >= 0 or either is NaN. + exit + end if + + ! Powell's code defines BARMU = -PREREF / PREREC, and CPEN is increased to 2*BARMU if and + ! only if it is currently less than 1.5*BARMU, a very "Powellful" scheme. In our implementation, + ! however, we set CPEN directly to the maximum between its current value and 2*BARMU while + ! handling possible overflow. This simplifies the scheme without worsening the performance. + cpen = max(cpen, min(-TWO * (preref / prerec), REALMAX)) + + if (findpole(cpen, cval, fval) == n + 1) then + exit + end if +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(cpen >= cpen_in .and. cpen > 0 .and. cpen <= REALMAX, 'CPEN >= CPEN_IN, CPEN > 0, and CPEN <= REALMAX', srname) + call assert(preref + cpen * prerec > 0 .or. info == DAMAGING_ROUNDING .or. & + & .not. (prerec >= 0 .and. max(prerec, preref) > 0) .or. .not. is_finite(preref) .or. & + cpen >= REALMAX, 'PREREF + CPEN*PREREC > 0 unless the rounding is damaging', srname) +end if +end function getcpen + + +function fcratio(conmat, fval) result(r) +!--------------------------------------------------------------------------------------------------! +! This function calculates the ratio between the "typical change" of F and that of CONSTR. +! See equations (12)--(13) in Section 3 of the COBYLA paper for the definition of the ratio. +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: consts_mod, only : RP, ZERO, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +implicit none + +! Inputs +real(RP), intent(in) :: conmat(:, :) ! CONMAT(M, N+1) +real(RP), intent(in) :: fval(:) ! FVAL(N+1) + +! Outputs +real(RP) :: r + +! Local variables +real(RP) :: cmax(size(conmat, 1)) +real(RP) :: cmin(size(conmat, 1)) +real(RP) :: denom +real(RP) :: fmax +real(RP) :: fmin +character(len=*), parameter :: srname = 'FCRATIO' + +! Preconditions +if (DEBUGGING) then + call assert(size(fval) >= 1, 'SIZE(FVAL) >= 1', srname) + call assert(size(conmat, 2) == size(fval), 'SIZE(CONMAT, 2) == SIZE(FVAL)', srname) + call assert(.not. any(is_nan(conmat) .or. is_posinf(conmat)), 'CONMAT does not contain NaN/+Inf', srname) + call assert(.not. any(is_nan(fval) .or. is_posinf(fval)), 'FVAL does not contain NaN/+Inf', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! N.B.: In the original version of COBYLA, Powell proposed the ratio for constraints in the form of +! CONSTR(X) >= 0, but the constraints we consider here are CONSTR(X) <= 0. Hence we need to change +! the sign of the constraints before defining CMIN and CMAX. +cmin = minval(-conmat, dim=2) +cmax = maxval(-conmat, dim=2) +fmin = minval(fval) +fmax = maxval(fval) +r = ZERO +if (any(cmin < HALF * cmax) .and. fmin < fmax) then + denom = minval(max(cmax, ZERO) - cmin, mask=(cmin < HALF * cmax)) + ! Powell mentioned the following alternative in Section 4 of his COBYLA paper. According to a + ! test on 20230610, it does not make much difference to the performance. + ! !denom = maxval(max(cmax, ZERO) - cmin, mask=(cmin < HALF * cmax)) + r = (fmax - fmin) / denom +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(r >= 0, 'R >= 0', srname) +end if +end function fcratio + + +end module cobylb_mod diff --git a/examples/fortran/prima/native/cobyla/geometry.f90 b/examples/fortran/prima/native/cobyla/geometry.f90 new file mode 100644 index 000000000..dcb581045 --- /dev/null +++ b/examples/fortran/prima/native/cobyla/geometry.f90 @@ -0,0 +1,304 @@ +module geometry_cobyla_mod +!--------------------------------------------------------------------------------------------------! +! This module contains subroutines concerning the geometry-improving of the interpolation set. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the COBYLA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2021 +! +! Last Modified: Sunday, April 21, 2024 PM03:25:55 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: setdrop_tr, geostep + + +contains + + +function setdrop_tr(ximproved, d, delta, rho, sim, simi) result(jdrop) +!--------------------------------------------------------------------------------------------------! +! This subroutine finds (the index) of a current interpolation point to be replaced with the +! trust-region trial point. See (19)--(22) of the COBYLA paper. +! N.B.: +! 1. If XIMPROVED == TRUE, then JDROP > 0 so that D is included into XPT. Otherwise, it is a bug. +! 2. COBYLA never sets JDROP = N+1. +! TODO: Check whether it improves the performance if JDROP = N+1 is allowed when XIMPROVED is TRUE. +! Note that UPDATEXFC should be revised accordingly. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : IK, RP, ZERO, ONE, TENTH, DEBUGGING +use, non_intrinsic :: linalg_mod, only : matprod, isinv, trueloc +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: debug_mod, only : assert + +implicit none + +! Inputs +logical, intent(in) :: ximproved +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: delta +real(RP), intent(in) :: rho +real(RP), intent(in) :: sim(:, :) ! SIM(N, N+1) +real(RP), intent(in) :: simi(:, :) ! SIMI(N, N) + +! Outputs +integer(IK) :: jdrop + +! Local variables +character(len=*), parameter :: srname = 'SETDROP_TR' +integer(IK) :: n +real(RP) :: distsq(size(sim, 2)) +real(RP) :: weight(size(sim, 2)) +real(RP) :: score(size(sim, 2)) +real(RP) :: simid(size(simi, 1)) +!real(RP) :: sigbar(size(sim, 1)) +!real(RP) :: veta(size(sim, 1)) +!real(RP) :: vsig(size(sim, 1)) +real(RP), parameter :: itol = TENTH + +! Sizes +n = int(size(sim, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(delta >= rho .and. rho > 0, 'DELTA >= RHO > 0', srname) + call assert(size(sim, 1) == n .and. size(sim, 2) == n + 1, 'SIZE(SIM) == [N, N+1]', srname) + call assert(all(is_finite(sim)), 'SIM is finite', srname) + call assert(all(sum(abs(sim(:, 1:n)), dim=1) > 0), 'SIM(:, 1:N) has no zero column', srname) + call assert(size(simi, 1) == n .and. size(simi, 2) == n, 'SIZE(SIMI) == [N, N]', srname) + call assert(all(is_finite(simi)), 'SIMI is finite', srname) + call assert(isinv(sim(:, 1:n), simi, itol), 'SIMI = SIM(:, 1:N)^{-1}', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +!--------------------------------------------------------------------------------------------------! +! The following code is Powell's scheme for defining JDROP. +!--------------------------------------------------------------------------------------------------! +!! JDROP = 0 by default. It cannot be removed, as JDROP may not be set below in some cases (e.g., +!! when XIMPROVED == FALSE, MAXVAL(ABS(SIMID)) <= 1, and MAXVAL(VETA) <= EDGMAX). +!jdrop = 0 +! +!! SIMID(J) is the value of the J-th Lagrange function at D. It is the counterpart of VLAG in UOBYQA +!! and DEN in NEWUOA/BOBYQA/LINCOA, but it excludes the value of the (N+1)-th Lagrange function. +!simid = matprod(simi, d) +!if (any(abs(simid) > 1) .or. (ximproved .and. any(.not. is_nan(simid)))) then +! jdrop = int(maxloc(abs(simid), mask=(.not. is_nan(simid)), dim=1), kind(jdrop)) +! !!MATLAB: [~, jdrop] = max(simid, [], 'omitnan'); +!end if +! +!! VETA(J) is the distance from the J-th vertex of the simplex to the best vertex, taking the trial +!! point SIM(:, N+1) + D into account. +!if (ximproved) then +! veta = sqrt(sum((sim(:, 1:n) - spread(d, dim=2, ncopies=n))**2, dim=1)) +! !!MATLAB: veta = sqrt(sum((sim(:, 1:n) - d).^2)); % d should be a column! Implicit expansion +!else +! veta = sqrt(sum(sim(:, 1:n)**2, dim=1)) +!end if +! +!! VSIG(J) (J=1, .., N) is the Euclidean distance from vertex J to the opposite face of the simplex. +!vsig = ONE / sqrt(sum(simi**2, dim=2)) +!sigbar = abs(simid) * vsig +! +!! The following JDROP will overwrite the previous one if its premise holds. FACTOR_DELTA = 1.1 +!! and FACTOR_ALPHA = 0.25. +!mask = (veta > factor_delta * delta .and. (sigbar >= factor_alpha * delta .or. sigbar >= vsig)) +!if (any(mask)) then +! jdrop = int(maxloc(veta, mask=mask, dim=1), kind(jdrop)) +! !!MATLAB: etamax = max(veta(mask)); jdrop = find(mask & ~(veta < etamax), 1, 'first'); +!end if +! +!! Powell's code does not include the following instructions. With Powell's code, if SIMID consists +!! of only NaN, then JDROP can be 0 even when XIMPROVED == TRUE (i.e., D reduces the merit function). +!! With the following code, JDROP cannot be 0 when XIMPROVED == TRUE, unless VETA is all NaN, which +!! should not happen if X0 does not contain NaN, the trust-region/geometry steps never contain NaN, +!! and we exit once encountering an iterate containing Inf (due to overflow). +!if (ximproved .and. jdrop <= 0) then ! Write JDROP <= 0 instead of JDROP == 0 for robustness. +! jdrop = int(maxloc(veta, mask=(.not. is_nan(veta)), dim=1), kind(jdrop)) +! !!MATLAB: [~, jdrop] = max(veta, [], 'omitnan'); +!end if +!--------------------------------------------------------------------------------------------------! +! Powell's scheme ends here. +!--------------------------------------------------------------------------------------------------! + + +! The following definition of JDROP is inspired by SETDROP_TR in UOBYQA/NEWUOA/BOBYQA/LINCOA. +! It is simpler and works better than Powell's scheme. Note that we allow JDROP to be N+1 if +! IMPROVEX is TRUE, whereas Powell's code does not. +! See also (4.1) of Scheinberg-Toint-2010: Self-Correcting Geometry in Model-Based Algorithms for +! Derivative-Free Unconstrained Optimization, which refers to the strategy here as the "combined +! distance/poisedness criteria". + +! DISTQ(J) is the square of the distance from the J-th vertex of the simplex to the "best" point so +! far, taking the trial point SIM(:, N+1) + D into account. +if (ximproved) then + distsq(1:n) = sum((sim(:, 1:n) - spread(d, dim=2, ncopies=n))**2, dim=1) + !!MATLAB: distsq = sum((sim(:, 1:n) - d).^2); % d should be a column! Implicit expansion + distsq(n + 1) = sum(d**2) +else + distsq(1:n) = sum(sim(:, 1:n)**2, dim=1) + distsq(n + 1) = ZERO +end if + +weight = max(ONE, distsq / max(rho, TENTH * delta)**2) ! Similar to Powell's NEWUOA code +! Other possible definitions of WEIGHT. +! !weight = distsq ! Similar to Powell's LINCOA code, but WRONG. See comments in LINCOA/geometry.f90. +! !weight = max(ONE, 25.0_RP * distsq / delta**2) ! Similar to Powell's BOBYQA code, works well +! !weight = max(ONE, TEN * distsq / delta**2) +! !weight = max(ONE, 1.0E2_RP * distsq / delta**2) +! !weight = max(ONE, distsq / rho**2) ! Similar to Powell's UOBYQA + +! If 1 <= J <= N, SIMID(J) is the value of the J-th Lagrange function at D; the value of the +! (N+1)-th Lagrange function is 1 - SUM(SIMID). [SIMID, 1 - SUM(SIMID)] is the counterpart of +! VLAG in UOBYQA and DEN in NEWUOA/BOBYQA/LINCOA. +simid = matprod(simi, d) +score = weight * abs([simid, ONE - sum(simid)]) + +! If XIMPROVED = FALSE (D does not render a better X), set SCORE(N+1) = -1 to avoid JDROP = N+1. +if (.not. ximproved) then + score(n + 1) = -ONE +end if + +! SCORE(J) is NaN implies SIMID(J) is NaN, but we want ABS(SIMID) to be big. So we exclude such J. +score(trueloc(is_nan(score))) = -ONE + +jdrop = 0 +! The following IF works a bit better than `IF (ANY(SCORE > 1) .OR. ANY(SCORE > 0) .AND. XIMPROVED)` +! from Powell's UOBYQA and NEWUOA code. +if (any(score > 0)) then ! Powell's BOBYQA and LINCOA code + jdrop = int(maxloc(score, dim=1), kind(jdrop)) + !!MATLAB: [~, jdrop] = max(score); +end if + +if ((ximproved .and. jdrop == 0) .or. jdrop < 0) then ! JDROP < 0 is impossible in theory. + jdrop = int(maxloc(distsq, dim=1), kind(jdrop)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(jdrop >= 0 .and. jdrop <= n + 1, '0 <= JDROP <= N+1', srname) + call assert(jdrop <= n .or. ximproved, 'JDROP <= n unless IMPROVEX = TRUE', srname) + call assert(jdrop >= 1 .or. .not. ximproved, 'JDROP >= 1 unless IMPROVEX = FALSE', srname) + ! JDROP >= 1 when XIMPROVED = TRUE unless NaN occurs in DISTSQ, which should not happen if the + ! starting point does not contain NaN and the trust-region/geometry steps never contain NaN. +end if + +end function setdrop_tr + + +function geostep(jdrop, amat, bvec, conmat, cpen, cval, delbar, fval, simi) result(d) +!--------------------------------------------------------------------------------------------------! +! This function calculates a geometry step so that the geometry of the interpolation set is improved +! when SIM(:, JDRO_GEO) is replaced with SIM(:, N+1) + D. See (15)--(17) of the COBYLA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : IK, RP, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: linalg_mod, only : matprod, inprod, norm, maximum + +implicit none + +! Inputs +integer(IK), intent(in) :: jdrop +real(RP), intent(in) :: amat(:, :) +real(RP), intent(in) :: bvec(:) +real(RP), intent(in) :: conmat(:, :) ! CONMAT(M, N+1) +real(RP), intent(in) :: cpen +real(RP), intent(in) :: cval(:) ! CVAL(N+1) +real(RP), intent(in) :: delbar +real(RP), intent(in) :: fval(:) ! FVAL(N+1) +real(RP), intent(in) :: simi(:, :) ! SIMI(N, N) + +! Outputs +real(RP) :: d(size(simi, 1)) ! D(N) + +! Local variables +character(len=*), parameter :: srname = 'GEOSTEP' +integer(IK) :: m +integer(IK) :: m_lcon +integer(IK) :: n +real(RP) :: A(size(simi, 1), size(conmat, 1)) +real(RP) :: cvnd +real(RP) :: cvpd +real(RP) :: g(size(simi, 1)) + +! Sizes +m_lcon = int(size(bvec), kind(m_lcon)) +m = int(size(conmat, 1), kind(m)) +n = int(size(simi, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= m_lcon .and. m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(delbar > 0, 'DELBAR > 0', srname) + call assert(cpen > 0, 'CPEN > 0', srname) + call assert(size(simi, 1) == n .and. size(simi, 2) == n, 'SIZE(SIMI) == [N, N]', srname) + call assert(all(is_finite(simi)), 'SIMI is finite', srname) + call assert(size(fval) == n + 1 .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN/+Inf', srname) + call assert(size(conmat, 1) == m .and. size(conmat, 2) == n + 1, 'SIZE(CONMAT) == [M, N+1]', srname) + call assert(.not. any(is_nan(conmat) .or. is_posinf(conmat)), 'CONMAT does not contain NaN/+Inf', srname) + call assert(size(cval) == n + 1 .and. .not. any(cval < 0 .or. is_nan(cval) .or. is_posinf(cval)), & + & 'SIZE(CVAL) == NPT and CVAL does not contain negative NaN/+Inf', srname) + call assert(jdrop >= 1 .and. jdrop <= n, '1 <= JDROP <= N', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! SIMI(JDROP, :) is a vector perpendicular to the face of the simplex to the opposite of vertex +! JDROP. Set D to the vector in this direction and with length DELBAR. +d = simi(jdrop, :) +d = delbar * (d / norm(d)) + +! The code below chooses the direction of D according to an approximation of the merit function. +! See (17) of the COBYLA paper and line 225 of Powell's cobylb.f. + +! Calculate the coefficients of the linear approximations to the objective and constraint functions. +! N.B.: CONMAT and SIMI have been updated after the last trust-region step, but G and A have not. +! So we cannot pass G and A from outside. +g = matprod(fval(1:n) - fval(n + 1), simi) +A(:, 1:m_lcon) = amat +A(:, m_lcon + 1:m) = transpose(matprod(conmat(m_lcon + 1:m, 1:n) - spread(conmat(m_lcon + 1:m, n + 1), dim=2, ncopies=n), simi)) +!!MATLAB: A(:, m_lcon+1:m) = simi'*(conmat(m_lcon+1:m, 1:n) - conmat(m_lcon+1:m, n+1))' % Implicit expansion for subtraction +! CVPD and CVND are the predicted constraint violation of D and -D by the linear models. +cvpd = maximum([ZERO, conmat(:, n + 1) + matprod(d, A)]) +cvnd = maximum([ZERO, conmat(:, n + 1) - matprod(d, A)]) +! Take -D if the linear models predict that its merit function value is lower. +if (-inprod(d, g) + cpen * cvnd < inprod(d, g) + cpen * cvpd) then + d = -d +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + ! In theory, ||S|| == DELBAR, which may be false due to rounding, but not too far. + ! It is crucial to ensure that the geometry step is nonzero, which holds in theory. + call assert(norm(d) > 0.9_RP * delbar .and. norm(d) <= 1.1_RP * delbar, & + & '||D|| == DELBAR', srname) +end if +end function geostep + + +end module geometry_cobyla_mod diff --git a/examples/fortran/prima/native/cobyla/initialize.f90 b/examples/fortran/prima/native/cobyla/initialize.f90 new file mode 100644 index 000000000..c1bd9bb19 --- /dev/null +++ b/examples/fortran/prima/native/cobyla/initialize.f90 @@ -0,0 +1,353 @@ +module initialize_cobyla_mod +!--------------------------------------------------------------------------------------------------! +! This module contains subroutines for initialization. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the COBYLA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2021 +! +! Last Modified: Tue 16 Sep 2025 12:35:23 PM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: initxfc, initfilt + + +contains + + +subroutine initxfc(calcfc, iprint, maxfun, amat, bvec, constr0, ctol, f0, ftarget, rhobeg, x0, nf, & + & chist, conhist, conmat, cval, fhist, fval, sim, simi, xhist, evaluated, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine does the initialization concerning X, function values, and constraints. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TENTH, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: evaluate_mod, only : evaluate, moderatec +use, non_intrinsic :: history_mod, only : savehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT +use, non_intrinsic :: linalg_mod, only : eye, inv, isinv, maximum, matprod +use, non_intrinsic :: message_mod, only : fmsg +use, non_intrinsic :: pintrf_mod, only : OBJCON + +implicit none + +! Inputs +procedure(OBJCON) :: calcfc ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfun +real(RP), intent(in) :: amat(:, :) ! AMAT(N, M_LCON) +real(RP), intent(in) :: bvec(:) ! BVEC(M_LCON) +real(RP), intent(in) :: constr0(:) ! CONSTR0(M) +real(RP), intent(in) :: ctol +real(RP), intent(in) :: f0 +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: x0(:) ! X0(N) + +! Outputs +integer(IK), intent(out) :: info +integer(IK), intent(out) :: nf +logical, intent(out) :: evaluated(:) ! EVALUATED(N+1) +real(RP), intent(out) :: chist(:) ! CHIST(MAXCHIST) +real(RP), intent(out) :: conhist(:, :) ! CONHIST(M, MAXCONHIST) +real(RP), intent(out) :: conmat(:, :) ! CONMAT(M, N+1) +real(RP), intent(out) :: cval(:) ! CVAL(N+1) +real(RP), intent(out) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out) :: fval(:) ! FVAL(N+1) +real(RP), intent(out) :: sim(:, :) ! SIM(N, N+1) +real(RP), intent(out) :: simi(:, :) ! SIMI(N, N) +real(RP), intent(out) :: xhist(:, :)! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'COBYLA' +character(len=*), parameter :: srname = 'INITIALIZE' +integer(IK) :: j +integer(IK) :: k +integer(IK) :: m +integer(IK) :: m_lcon +integer(IK) :: maxchist +integer(IK) :: maxconhist +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: subinfo +real(RP) :: constr(size(conmat, 1)) +real(RP) :: cstrv +real(RP) :: f +real(RP) :: x(size(x0)) +real(RP), parameter :: itol = TENTH + +! Sizes +m_lcon = int(size(bvec), kind(m_lcon)) +m = int(size(conmat, 1), kind(m)) +n = int(size(sim, 1), kind(n)) +maxchist = int(size(chist), kind(maxchist)) +maxconhist = int(size(conhist, 2), kind(maxconhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxhist = int(max(maxchist, maxconhist, maxfhist, maxxhist), kind(maxhist)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(size(amat, 1) == n .and. size(amat, 2) == size(bvec), 'SIZE(AMAT) == [N, SIZE(BVEC)]', srname) + call assert(size(conmat, 1) == m .and. size(conmat, 2) == n + 1, 'SIZE(CONMAT) = [M, N+1]', srname) + call assert(size(cval) == n + 1, 'SIZE(CVAL) == N+1', srname) + call assert(size(fval) == n + 1, 'SIZE(FVAL) == N+1', srname) + call assert(size(sim, 1) == n .and. size(sim, 2) == n + 1, 'SIZE(SIM) == [N, N+1]', srname) + call assert(size(simi, 1) == n .and. size(simi, 2) == n, 'SIZE(SIMI) == [N, N]', srname) + call assert(size(evaluated) == n + 1, 'SIZE(EVALUATED) == N + 1', srname) + call assert(maxchist * (maxchist - maxhist) == 0, 'SIZE(CHIST) == 0 or MAXHIST', srname) + call assert(size(conhist, 1) == m .and. maxconhist * (maxconhist - maxhist) == 0, & + & 'SIZE(CONHIST, 1) == M, SIZE(CONHIST, 2) == 0 or MAXHIST', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(size(x0) == n .and. all(is_finite(x0)), 'SIZE(X0) == N, X0 is finite', srname) + call assert(rhobeg > 0, 'RHOBEG > 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialize INFO to the default value. At return, an INFO different from this value will indicate +! an abnormal return. +info = INFO_DFT + +! Initialize the simplex. It will be revised during the initialization. +sim = eye(n, n + 1_IK) * rhobeg +sim(:, n + 1) = x0 + +! Initialize the matrix SIMI. This initial value will be discarded at the end of the initialization. +! If we do not do this, compilers may complain if we return due to CHECKEXIT before SIMI is set. +simi = eye(n) / rhobeg + +! EVALUATED(J) = TRUE iff the function/constraint of SIM(:, J) has been evaluated. +evaluated = .false. + +! Initialize XHIST, FHIST, CHIST, CONHIST, FVAL, CVAL, and CONMAT. Otherwise, compilers may complain +!that they are not (completely) initialized if the initialization aborts due to abnormality (see +!CHECKEXIT). +! N.B.: 1. Initializing them to NaN would be more reasonable (NaN is not available in Fortran). +! 2. Do not initialize the models if the current initialization aborts due to abnormality. Otherwise, +! errors or exceptions may occur, as FVAL and XPT etc are uninitialized. +xhist = -REALMAX +fhist = REALMAX +chist = REALMAX +conhist = REALMAX +fval = REALMAX +cval = REALMAX +conmat = REALMAX + +do k = 1, n + 1_IK + x = sim(:, n + 1) + ! We will evaluate F corresponding to SIM(:, J). + if (k == 1) then + j = n + 1_IK + f = f0 + constr = constr0 + else + j = k - 1_IK + x(j) = x(j) + rhobeg + constr(1:m_lcon) = moderatec(matprod(x, amat) - bvec) ! Linear constraints. + call evaluate(calcfc, x, f, constr(m_lcon + 1:m)) ! Nonlinear constraints. + ! Note that EVALUATE moderates the nonlinear constraint values. Thus we also moderate the + ! linear constraint values here to make CSTRV consistent. + end if + cstrv = maximum([ZERO, constr]) + + ! Print a message about the function/constraint evaluation according to IPRINT. + call fmsg(solver, 'Initialization', iprint, k, rhobeg, f, x, cstrv, constr) + ! Save X, F, CONSTR, CSTRV into the history. + call savehist(k, x, xhist, f, fhist, cstrv, chist, constr, conhist) + + ! Save F, CONSTR, and CSTRV to FVAL, CONMAT, and CVAL respectively. This must be done before + ! checking whether to exit. If exit, FVAL, CONMAT, and CVAL will define FFILT, CONFILT, and + ! CFILT, which will define the returned X, F, CONSTR, and CSTRV. + evaluated(j) = .true. + fval(j) = f + conmat(:, j) = constr + cval(j) = cstrv + + ! Check whether to exit. + subinfo = checkexit(maxfun, k, cstrv, ctol, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + + ! Exchange the new vertex of the initial simplex with the optimal vertex if necessary. + ! This is the ONLY part that is essentially non-parallel. + if (j <= n .and. fval(j) < fval(n + 1)) then + fval([j, n + 1_IK]) = fval([n + 1_IK, j]) + cval([j, n + 1_IK]) = cval([n + 1_IK, j]) + conmat(:, [j, n + 1_IK]) = conmat(:, [n + 1_IK, j]) + sim(:, n + 1) = x + sim(j, 1:j) = -rhobeg ! SIM(:, 1:N) is lower triangular. + end if +end do + +nf = int(count(evaluated), kind(nf)) + +if (all(evaluated)) then + ! Initialize SIMI to the inverse of SIM(:, 1:N). + simi = inv(sim(:, 1:n)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(evaluated) == n + 1, 'SIZE(EVALUATED) == N + 1', srname) + call assert(size(chist) == maxchist, 'SIZE(CHIST) == MAXCHIST', srname) + call assert(.not. any(chist(1:min(nf, maxchist)) < 0 .or. is_nan(chist(1:min(nf, maxchist))) & + & .or. is_posinf(chist(1:min(nf, maxchist)))), 'CHIST does not contain negative values or NaN/+Inf', srname) + call assert(size(conhist, 1) == m .and. size(conhist, 2) == maxconhist, & + & 'SIZE(CONHIST) == [M, MAXCONHIST]', srname) + call assert(.not. any(is_nan(conhist(:, 1:min(nf, maxconhist))) .or. & + & is_posinf(conhist(:, 1:min(nf, maxconhist)))), 'CONHIST does not contain NaN/+Inf', srname) + call assert(size(conmat, 1) == m .and. size(conmat, 2) == n + 1, 'SIZE(CONMAT) = [M, N+1]', srname) + call assert(.not. any(is_nan(conmat) .or. is_posinf(conmat)), 'CONMAT does not contain NaN/+Inf', srname) + call assert(size(cval) == n + 1 .and. .not. any(cval < 0 .or. is_nan(cval) .or. is_posinf(cval)), & + & 'SIZE(CVAL) == N+1 and CVAL does not contain negative values or NaN/+Inf', srname) + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(size(fval) == n + 1 .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == N+1 and FVAL does not contain NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + call assert(size(sim, 1) == n .and. size(sim, 2) == n + 1, 'SIZE(SIM) == [N, N+1]', srname) + call assert(all(is_finite(sim)), 'SIM is finite', srname) + call assert(all(sum(abs(sim(:, 1:n)), dim=1) > 0), 'SIM(:, 1:N) has no zero column', srname) + call assert(size(simi, 1) == n .and. size(simi, 2) == n, 'SIZE(SIMI) == [N, N]', srname) + call assert(all(is_finite(simi)), 'SIMI is finite', srname) + call assert(isinv(sim(:, 1:n), simi, itol) .or. any(.not. evaluated), 'SIMI = SIM(:, 1:N)^{-1}', srname) +end if + +end subroutine initxfc + + +subroutine initfilt(conmat, ctol, cweight, cval, fval, sim, evaluated, nfilt, cfilt, confilt, ffilt, xfilt) +!--------------------------------------------------------------------------------------------------! +! This subroutine initializes the filters (XFILT, etc) that will be used when selecting X at the +! end of the solver. +! N.B.: +! 1. Why not initialize the filters using XHIST, etc? Because the history is empty if the user +! chooses not to output it. +! 2. We decouple INITXFC and INITFILT so that it is easier to parallelize the former if needed. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: selectx_mod, only : savefilt +implicit none + +! Inputs +real(RP), intent(in) :: conmat(:, :) +real(RP), intent(in) :: ctol +real(RP), intent(in) :: cweight +real(RP), intent(in) :: cval(:) +real(RP), intent(in) :: fval(:) +real(RP), intent(in) :: sim(:, :) +logical, intent(in) :: evaluated(:) + +! In-outputs +integer(IK), intent(inout) :: nfilt +real(RP), intent(inout) :: cfilt(:) +real(RP), intent(inout) :: confilt(:, :) +real(RP), intent(inout) :: ffilt(:) +real(RP), intent(inout) :: xfilt(:, :) + +! Local variables +character(len=*), parameter :: srname = 'INITFILT' +integer(IK) :: i +integer(IK) :: m +integer(IK) :: maxfilt +integer(IK) :: n +real(RP) :: x(size(sim, 1)) + +! Sizes +m = int(size(conmat, 1), kind(m)) +n = int(size(sim, 1), kind(n)) +maxfilt = int(size(ffilt), kind(maxfilt)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(maxfilt >= 1, 'MAXFILT >= 1', srname) + call assert(size(confilt, 1) == m .and. size(confilt, 2) == maxfilt, 'SIZE(CONFILT) == [M, MAXFILT]', srname) + call assert(size(cfilt) == maxfilt, 'SIZE(CFILT) == MAXFILT', srname) + call assert(size(xfilt, 1) == n .and. size(xfilt, 2) == maxfilt, 'SIZE(XFILT) == [N, MAXFILT]', srname) + call assert(size(ffilt) == maxfilt, 'SIZE(FFILT) == MAXFILT', srname) + call assert(size(conmat, 1) == m .and. size(conmat, 2) == n + 1, 'SIZE(CONMAT) = [M, N+1]', srname) + call assert(.not. any(is_nan(conmat) .or. is_posinf(conmat)), 'CONMAT does not contain NaN/+Inf', srname) + call assert(size(cval) == n + 1 .and. .not. any(cval < 0 .or. is_nan(cval) .or. is_posinf(cval)), & + & 'SIZE(CVAL) == N+1 and CVAL does not contain negative values or NaN/+Inf', srname) + call assert(size(fval) == n + 1 .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == N+1 and FVAL does not contain NaN/+Inf', srname) + call assert(size(sim, 1) == n .and. size(sim, 2) == n + 1, 'SIZE(SIM) == [N, N+1]', srname) + call assert(all(is_finite(sim)), 'SIM is finite', srname) + call assert(all(sum(abs(sim(:, 1:n)), dim=1) > 0), 'SIM(:, 1:N) has no zero column', srname) + call assert(size(evaluated) == n + 1, 'SIZE(EVALUATED) == N + 1', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +nfilt = 0 +do i = 1, n + 1_IK + if (evaluated(i)) then + if (i <= n) then + x = sim(:, i) + sim(:, n + 1) + else + x = sim(:, i) ! I == N+1 + end if + call savefilt(cval(i), ctol, cweight, fval(i), x, nfilt, cfilt, ffilt, xfilt, conmat(:, i), confilt) + end if +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nfilt <= maxfilt, 'NFILT <= MAXFILT', srname) + call assert(size(confilt, 1) == m .and. size(confilt, 2) == maxfilt, 'SIZE(CONFILT) == [M, MAXFILT]', srname) + call assert(.not. any(is_nan(confilt(:, 1:nfilt)) .or. is_posinf(confilt(:, 1:nfilt))), & + & 'CONFILT does not contain NaN/+Inf', srname) + call assert(size(cfilt) == maxfilt, 'SIZE(CFILT) == MAXFILT', srname) + call assert(.not. any(cfilt(1:nfilt) < 0 .or. is_nan(cfilt(1:nfilt)) .or. is_posinf(cfilt(1:nfilt))), & + & 'CFILT does not contain negative values or NaN/Inf', srname) + call assert(size(xfilt, 1) == n .and. size(xfilt, 2) == maxfilt, 'SIZE(XFILT) == [N, MAXFILT]', srname) + call assert(.not. any(is_nan(xfilt(:, 1:nfilt))), 'XFILT does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(ffilt) == maxfilt, 'SIZE(FFILT) == MAXFILT', srname) + call assert(.not. any(is_nan(ffilt(1:nfilt)) .or. is_posinf(ffilt(1:nfilt))), & + & 'FFILT does not contain NaN/+Inf', srname) +end if +end subroutine initfilt + + +end module initialize_cobyla_mod diff --git a/examples/fortran/prima/native/cobyla/trustregion.f90 b/examples/fortran/prima/native/cobyla/trustregion.f90 new file mode 100644 index 000000000..b4f1d7b78 --- /dev/null +++ b/examples/fortran/prima/native/cobyla/trustregion.f90 @@ -0,0 +1,670 @@ +module trustregion_cobyla_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning the trust-region calculations of COBYLA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the COBYLA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: June 2021 +! +! Last Modified: Saturday, March 16, 2024 AM03:37:33 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: trstlp +public :: trrad + + +contains + + +function trstlp(A, b, delta, g) result(d) +!--------------------------------------------------------------------------------------------------! +! This subroutine calculates an N-component vector D by the following two stages. In the first +! stage, D is set to the shortest vector that minimizes the greatest violation of the constraints +! A^T * D <= B, K = 1, 2, 3, ..., M, +! subject to the Euclidean length of D being at most DELTA. If its length is strictly less than +! DELTA, then the second stage uses the resultant freedom in D to minimize the objective function +! G^T * D +! subject to no increase in any greatest constraint violation. +! +! It is possible but rare that a degeneracy may prevent D from attaining the target length DELTA. +! +! CVIOL is the largest constraint violation of the current D: MAXVAL([A^T*D-B, ZERO]). +! ICON is the index of a most violated constraint if CVIOL is positive. +! +! NACT is the number of constraints in the active set and IACT(1), ...,IACT(NACT) are their indices, +! while the remainder of IACT contains a permutation of the remaining constraint indices. +! N.B.: NACT <= min(M, N). Obviously, NACT <= M. In addition, The constraints in IACT(1, ..., NACT) +! have linearly independent gradients (see the comments above the instructions that delete a +! constraint from the active set to make room for the new active constraint with index IACT(ICON)); +! it can also be seen from the update of NACT: starting from 0, NACT is incremented only if NACT < N. +! +! Further, Z is an orthogonal matrix whose first NACT columns can be regarded as the result of +! Gram-Schmidt applied to the active constraint gradients. For J = 1, 2, ..., NACT, the number +! ZDOTA(J) is the scalar product of the J-th column of Z with the gradient of the J-th active +! constraint. D is the current vector of variables and here the residuals of the active constraints +! should be zero. Further, the active constraints have nonnegative Lagrange multipliers that are +! held at the beginning of VMULTC. The remainder of this vector holds the residuals of the inactive +! constraints at D, the ordering of the components of VMULTC being in agreement with the permutation +! of the indices of the constraints that is in IACT. All these residuals are nonnegative, which is +! achieved by the shift CVIOL that makes the least residual zero. +! +! N.B.: +! 0. In Powell's implementation, the constraints are A^T * D >= B. In other words, the A and B in +! our implementation are the negative of those in Powell's implementation. +! 1. The algorithm was NOT documented in the COBYLA paper. A note should be written to introduce it! +! 2. As a major part of the algorithm (see TRSTLP_SUB), the code maintains and updates the QR +! factorization of A(:, IACT(1:NACT)), i.e., the gradients of all the active (linear) constraints. +! The matrix Z is indeed Q, and the vector ZDOTA is the diagonal of R. The factorization is updated +! by Givens rotations when an index is added in or removed from IACT. +! 3. There are probably better algorithms available for the trust-region linear programming problem. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, REALMIN, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : norm +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) ! A(N, M) +real(RP), intent(in) :: b(:) ! B(M) +real(RP), intent(in) :: delta +real(RP), intent(in) :: g(:) ! G(N) + +! Outputs +real(RP) :: d(size(A, 1)) ! D(N) + +! Local variables +character(len=*), parameter :: srname = 'TRSTLP' +integer(IK) :: i +integer(IK) :: iact(size(b) + 1) +integer(IK) :: m +integer(IK) :: n +integer(IK) :: nact +real(RP) :: A_aug(size(A, 1), size(A, 2) + 1) +real(RP) :: b_aug(size(b) + 1) +real(RP) :: modscal +real(RP) :: vmultc(size(b) + 1) +real(RP) :: z(size(d), size(d)) + +! Sizes +m = int(size(A, 2), kind(m)) +n = int(size(A, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(m >= 0, 'M >= 0', srname) + call assert(size(g) == n, 'SIZE(G) == N', srname) + call assert(size(d) == n, 'SIZE(D) == N', srname) + call assert(size(b) == m, 'SIZE(B) == M', srname) + call assert(delta > 0, 'DELTA > 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Form A_aug and B_aug. This allows the gradient of the objective function to be regarded as the +! gradient of a constraint in the second stage. +A_aug = reshape([A, g], [n, m + 1_IK]) !!MATLAB: A_aug = [A, g]; +b_aug = [b, ZERO] !!MATLAB: b_aug = [b; 0]; + +! Scale the problem if A_aug contains large values. Otherwise, floating point exceptions may occur. +! Note that the trust-region step is scale invariant. +! N.B.: It is faster and safer to scale by multiplying a reciprocal than by division. See +! https://fortran-lang.discourse.group/t/ifort-ifort-2021-8-0-1-0e-37-1-0e-38-0/ +do i = 1, m + 1_IK ! Note that SIZE(A, 2) = SIZE(B) = M + 1 /= M. + if (maxval(abs(A_aug(:, i))) > 1.0E12) then + modscal = max(TWO * REALMIN, ONE / maxval(abs(A_aug(:, i)))) ! MAX: avoid underflow. + A_aug(:, i) = A_aug(:, i) * modscal + b_aug(i) = b_aug(i) * modscal + end if +end do + +! Stage 1: minimize the l_infinity constraint violation of the linearized constraints. +call trstlp_sub(iact(1:m), nact, 1_IK, A_aug(:, 1:m), b_aug(1:m), delta, d, vmultc(1:m), z) + +! Stage 2: minimize the linearized objective without increasing the l_infinity constraint violation. +call trstlp_sub(iact, nact, 2_IK, A_aug, b_aug, delta, d, vmultc, z) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(d) == n, 'SIZE(D) == N', srname) + call assert(all(is_finite(d)), 'D is finite', srname) + ! Due to rounding, it may happen that ||D|| > DELTA, but ||D|| > 2*DELTA is highly improbable. + call assert(norm(d) <= TWO * delta, '||D|| <= 2*DELTA', srname) +end if +end function trstlp + + +subroutine trstlp_sub(iact, nact, stage, A, b, delta, d, vmultc, z) +!--------------------------------------------------------------------------------------------------! +! This subroutine does the real calculations for TRSTLP, both stage 1 and stage 2. +! Major differences between stage 1 and stage 2: +! 1. Initialization. Stage 2 inherits the values of some variables from stage 1, so they are +! initialized in stage 1 but not in stage 2. +! 2. CVIOL. CVIOL is updated after at iteration in stage 1, while it remains a constant in stage 2. +! 3. SDIRN. See the definition of SDIRN in the code for details. +! 4. OPTNEW. The two stages have different objectives, so OPTNEW is updated differently. +! 5. STEP. STEP <= CVIOL in stage 1. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, REALMAX, EPS, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert, validate +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : inprod, matprod, eye, isminor, lsqr, norm, linspace, trueloc, maximum +use, non_intrinsic :: powalg_mod, only : qradd, qrexc +implicit none + +! Inputs +integer(IK), intent(in) :: stage +real(RP), intent(in) :: A(:, :) ! A(N, MCON) +real(RP), intent(in) :: b(:) ! B(M) +real(RP), intent(in) :: delta + +! In-outputs +integer(IK), intent(inout) :: iact(:) ! IACT(MCON) +integer(IK), intent(inout) :: nact +real(RP), intent(inout) :: d(:) ! D(N) +real(RP), intent(inout) :: vmultc(:) ! VMULTC(MCON) +real(RP), intent(inout) :: z(:, :) ! Z(N, N) + +! Local variables +character(len=*), parameter :: srname = 'TRSTLP_SUB' +integer(IK) :: icon +integer(IK) :: iter +integer(IK) :: k +integer(IK) :: m +integer(IK) :: maxiter +integer(IK) :: mcon +integer(IK) :: n +integer(IK) :: nactold +integer(IK) :: nactsav +integer(IK) :: nfail +real(RP) :: cviol +!real(RP) :: cvold +real(RP) :: cvsabs(size(b)) +real(RP) :: cvshift(size(b)) +real(RP) :: dd +real(RP) :: dnew(size(d)) +real(RP) :: dold(size(d)) +real(RP) :: frac +real(RP) :: fracmult(size(vmultc)) +real(RP) :: optnew +real(RP) :: optold +real(RP) :: sd +real(RP) :: sdirn(size(d)) +real(RP) :: sqrtd +real(RP) :: ss +real(RP) :: step +real(RP) :: vmultd(size(vmultc)) +real(RP) :: zdasav(size(z, 2)) +real(RP) :: zdota(size(z, 2)) + +! Sizes +mcon = int(size(A, 2), kind(mcon)) +n = int(size(A, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(stage == 1 .or. stage == 2, 'STAGE == 1 or 2', srname) + call assert((mcon >= 0 .and. stage == 1) .or. (mcon >= 1 .and. stage == 2), & + & 'MCON >= 1 in stage 1 and MCON >= 0 in stage 2', srname) + call assert(size(b) == mcon, 'SIZE(B) == MCON', srname) + call assert(size(iact) == mcon, 'SIZE(IACT) == MCON', srname) + call assert(size(vmultc) == mcon, 'SIZE(VMULTC) == MCON', srname) + call assert(size(d) == n, 'SIZE(D) == N', srname) + call assert(size(z, 1) == n .and. size(z, 2) == n, 'SIZE(Z) == [N, N]', srname) + call assert(delta > 0, 'DELTA > 0', srname) + if (stage == 2) then + call assert(all(is_finite(d)) .and. norm(d) <= TWO * delta, & + & 'D is finite and ||D|| <= 2*DELTA at the beginning of stage 2', srname) + call assert((nact >= 0 .and. nact <= min(mcon, n)), & + & '0 <= NACT <= MIN(MCON, N) at the beginning of stage 2', srname) + call assert(precision(0.0_RP) < precision(0.0D0) .or. all(vmultc(1:mcon - 1) >= 0), & + & 'VMULTC >= 0 at the beginning of stage 2', srname) + ! N.B.: Stage 1 defines only VMULTC(1:M); VMULTC(M+1) is undefined! + end if +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialization according to STAGE. +if (stage == 1) then + iact = linspace(1_IK, mcon, mcon) !!MATLAB: iact = (1:mcon); % Row vector + ! N.B.: 1. The MATLAB version of LINSPACE returns a row vector. Take a transpose if needed. + ! 2. In MATLAB, linspace(1, mcon, mcon) can also be written as (1:mcon). + nact = 0 + d = ZERO + cviol = maximum([ZERO, -b]) + vmultc = cviol + b + z = eye(n) + if (mcon == 0 .or. cviol <= 0) then + ! Check whether a quick return is possible. Make sure the In-outputs have been initialized. + return + end if + + if (all(is_nan(b))) then + return + else + icon = int(maxloc(-b, mask=(.not. is_nan(b)), dim=1), kind(icon)) + !!MATLAB: [~, icon] = max(b, [], 'omitnan'); + end if + m = mcon + sdirn = ZERO +else + if (inprod(d, d) >= delta**2) then + ! Check whether a quick return is possible. + return + end if + + iact(mcon) = mcon + vmultc(mcon) = ZERO + m = mcon - 1_IK + icon = mcon + + ! In Powell's code, stage 2 uses the ZDOTA and CVIOL calculated by stage 1. Here we re-calculate + ! them so that they need not be passed from stage 1 to 2, and hence the coupling is reduced. + cviol = maximum([ZERO, matprod(d, A(:, 1:m)) - b(1:m)]) +end if +zdota(1:nact) = [(inprod(z(:, k), A(:, iact(k))), k=1, nact)] +!!MATLAB: zdota(1:nact) = sum(z(:, 1:nact) .* A(:, iact(1:nact)), 1); % Row vector + +! More initialization. +optold = REALMAX +nactold = nact +nfail = 0 + +!----------------------------------------------------------------------------------------------! +! Zaikun 20211011: VMULTD is computed from scratch at each iteration, but VMULTC is inherited. +!----------------------------------------------------------------------------------------------! + +! Powell's code can encounter infinite cycling, which did happen when testing the following CUTEst +! problems: DANWOODLS, GAUSS1LS, GAUSS2LS, GAUSS3LS, KOEBHELB, TAX13322, TAXR13322. Indeed, in all +! these cases, Inf/NaN appear in D due to extremely large values in A (up to 10^219). To resolve +! this, we set the maximal number of iterations to MAXITER, and terminate if Inf/NaN occurs in D. +! The formulation of MAXITER below contains a precaution against overflow. In MATLAB/Python/Julia/R, +! we can write maxiter = min(10000, 100*max(m, n)) +maxiter = int(min(10**min(4, range(0_IK)), 100 * int(max(m, n))), IK) +do iter = 1, maxiter + if (DEBUGGING) then + call assert(precision(0.0_RP) < precision(0.0D0) .or. all(vmultc >= 0), 'VMULTC >= 0', srname) + end if + if (stage == 1) then + optnew = cviol + else + optnew = inprod(d, A(:, mcon)) + end if + + ! End the current stage of the calculation if 3 consecutive iterations have either failed to + ! reduce the best calculated value of the objective function or to increase the number of active + ! constraints since the best value was calculated. This strategy prevents cycling, but there is + ! a remote possibility that it will cause premature termination. + if (optnew < optold .or. nact > nactold) then + nactold = nact + nfail = 0 + else + nfail = nfail + 1_IK + end if + optold = min(optold, optnew) + if (nfail == 3) then + exit + end if + + ! If ICON exceeds NACT, then we add the constraint with index IACT(ICON) to the active set. + if (icon > nact) then + zdasav(1:nact) = zdota(1:nact) + nactsav = nact + call qradd(A(:, iact(icon)), z, zdota, nact) ! QRADD may update NACT to NACT + 1. + ! Indeed, it suffices to pass ZDOTA(1:MIN(N, NACT+1)) to QRADD as follows. + ! !call qradd(A(:, iact(icon)), z, zdota(1:min(n, nact + 1_IK)), nact) + + if (nact == nactsav + 1) then + ! N.B.: It is problematic to index arrays using [NACT, ICON] when NACT == ICON. + ! Zaikun 20211012: Why should VMULTC(NACT) = 0? + if (nact /= icon) then + vmultc([icon, nact]) = [vmultc(nact), ZERO] + iact([icon, nact]) = iact([nact, icon]) + else + vmultc(nact) = ZERO + end if + else + ! Zaikun 20211011: + ! 1. VMULTD is calculated from scratch for the first time (out of 2) in one iteration. + ! 2. NOTE that IACT has not been updated to replace IACT(NACT) with IACT(ICON). Thus + ! A(:, IACT(1:NACT)) is the UNUPDATED version before QRADD (Z(:, 1:NACT) remains the + ! same before and after QRADD). Therefore, if we supply ZDOTA to LSQR (as Rdiag) as + ! Powell did, we should use the UNUPDATED version, namely ZDASAV. + vmultd(1:nact) = lsqr(A(:, iact(1:nact)), A(:, iact(icon)), z(:, 1:nact), zdasav(1:nact)) + if (.not. any(vmultd(1:nact) > 0 .and. iact(1:nact) <= m)) then + ! N.B.: This can be triggered by NACT == 0 (among other possibilities)! This is + ! important, because NACT will be used as an index in the sequel. + exit + end if + ! VMULTD(NACT+1:MCON) is not used, but we have to initialize it in Fortran, or compilers + ! complain about the WHERE construct below (another solution: restrict WHERE to 1:NACT). + vmultd(nact + 1:mcon) = -ONE ! SIZE(VMULTD) = MCON + + ! Revise the Lagrange multipliers. The revision is not applicable to VMULTC(NACT + 1:M). + fracmult = REALMAX + where (vmultd > 0 .and. iact <= m) fracmult = vmultc / vmultd + !!MATLAB: mask = (vmultd > 0 & iact <= m); fracmult(mask) = vmultc(mask) / vmultd(mask); + ! Only the places with VMULTD > 0 and IACT <= M is relevant blow, if any. + frac = minval(fracmult(1:nact)) ! FRACMULT(NACT+1:MCON) may contain garbage. + vmultc(1:nact) = max(ZERO, vmultc(1:nact) - frac * vmultd(1:nact)) + + ! Reorder the active constraints so that the one to be replaced is at the end of the list. + ! Exit if the new value of ZDOTA(NACT) is not acceptable. Powell's condition for the + ! following IF: .NOT. ABS(ZDOTA(NACT)) > 0. Note that it is different from + ! 'ABS(ZDOTA(NACT) <= 0)', as ZDOTA(NACT) can be NaN. + ! N.B.: We cannot arrive here with NACT == 0, which should have triggered an exit above. + if (is_nan(zdota(nact)) .or. abs(zdota(nact)) <= EPS**2) then + exit + end if + vmultc([icon, nact]) = [ZERO, frac] ! VMULTC([ICON, NACT]) is valid as ICON > NACT. + iact([icon, nact]) = iact([nact, icon]) + end if + + ! In stage 2, ensure that the objective continues to be treated as the last active constraint. + ! Zaikun 20211011, 20211111: Is it guaranteed for stage 2 that IACT(NACT-1) = MCON when + ! IACT(NACT) /= MCON??? If not, then how does the following procedure ensure that MCON is + ! the last of IACT(1:NACT)? + if (stage == 2 .and. iact(nact) /= mcon) then + if (nact <= 1) then + ! We must exit, as NACT-1 is used as an index below. Powell's code does not have this. + exit + end if + call qrexc(A(:, iact(1:nact)), z, zdota(1:nact), nact - 1_IK) + ! Indeed, it suffices to pass Z(:, 1:NACT) to QREXC as follows. + ! !call qrexc(A(:, iact(1:nact)), z(:, 1:nact), zdota(1:nact), nact - 1_IK) + iact([nact - 1_IK, nact]) = iact([nact, nact - 1_IK]) + vmultc([nact - 1_IK, nact]) = vmultc([nact, nact - 1_IK]) + end if + ! Zaikun 20211117: It turns out that the last few lines do not guarantee IACT(NACT) == N in + ! stage 2; the following test cannot be passed. IS THIS A BUG?! + ! !call assert(iact(nact) == mcon .or. stage == 1, 'IACT(NACT) == MCON in stage 2', srname) + + ! Powell's code does not have the following. It avoids subsequent floating point exceptions. + !------------------------------------------------------------------------------------------! + if (is_nan(zdota(nact)) .or. abs(zdota(nact)) <= EPS**2) then + exit + end if + !------------------------------------------------------------------------------------------! + + ! Set SDIRN to the direction of the next change to the current vector of variables. + ! Usually during stage 1 the vector SDIRN gives a search direction that reduces all the + ! active constraint violations by one simultaneously. + if (stage == 1) then + sdirn = sdirn - ((inprod(sdirn, A(:, iact(nact))) + ONE) / zdota(nact)) * z(:, nact) + else + sdirn = -(ONE / zdota(nact)) * z(:, nact) + ! SDIRN = Z(:, NACT)/(A(:,IACT(NACT))^T*Z(:, NACT)) + ! SDIRN^T*A(:, IACT(NACT)) = 1, SDIRN is orthogonal to A(:, IACT(1:NACT-1)) and is + ! parallel to Z(:, NACT). + end if + else ! ICON <= NACT + ! Delete the constraint with the index IACT(ICON) from the active set, which is done by + ! reordering IACT(ICONT:NACT) into [IACT(ICON+1:NACT), IACT(ICON)] by pairwise exchanges + ! and then reduce NACT to NACT - 1. In theory, ICON > 0. + call validate(icon > 0, 'ICON > 0', srname) + call qrexc(A(:, iact(1:nact)), z, zdota(1:nact), icon) ! QREXC does nothing if ICON==NACT. + ! Indeed, it suffices to pass Z(:, 1:NACT) to QREXC as follows. + ! !call qrexc(A(:, iact(1:nact)), z(:, 1:nact), zdota(1:nact), icon) + iact(icon:nact) = [iact(icon + 1:nact), iact(icon)] + vmultc(icon:nact) = [vmultc(icon + 1:nact), vmultc(icon)] + nact = nact - 1_IK + + ! Powell's code does not have the following. It avoids subsequent exceptions. + !------------------------------------------------------------------------------------------! + ! Zaikun 20221212: In theory, NACT > 0 in stage 2, as the objective function should always + ! be considered as an "active constraint" --- more precisely, IACT(NACT) = MCON. However, + ! looking at the code, I cannot see why in stage 2 NACT must be positive after the reduction + ! above. It did happen in stage 1 that NACT became 0 after the reduction --- this is + ! extremely rare, and it was never observed until 20221212, after almost one year of + ! random tests. Maybe NACT is theoretically positive even in stage 1? + if (stage == 2 .and. nact <= 0) then + exit ! If this case ever occurs, we have to exit, as NACT is used as an index below. + end if + if (nact > 0) then + if (is_nan(zdota(nact)) .or. abs(zdota(nact)) <= EPS**2) then + exit + end if + end if + !------------------------------------------------------------------------------------------! + + ! Set SDIRN to the direction of the next change to the current vector of variables. + if (stage == 1) then + sdirn = sdirn - inprod(sdirn, z(:, nact + 1)) * z(:, nact + 1) + ! SDIRN is orthogonal to Z(:, NACT+1) + else + sdirn = -(ONE / zdota(nact)) * z(:, nact) + ! SDIRN = Z(:, NACT)/(A(:,IACT(NACT))^T*Z(:, NACT)) + ! SDIRN^T*A(:, IACT(NACT)) = 1, SDIRN is orthogonal to A(:, IACT(1:NACT-1)) and is + ! parallel to Z(:, NACT). + end if + end if + + ! Calculate the step to the trust region boundary or take the step that reduces CVIOL to 0. + !----------------------------------------------------------------------------------------------! + ! The following calculation of STEP is adopted from NEWUOA/BOBYQA/LINCOA. It seems to improve + ! the performance of COBYLA. We also found that removing the precaution about underflows is + ! beneficial to the overall performance of COBYLA --- the underflows are harmless anyway. + dd = delta**2 - inprod(d, d) + ss = inprod(sdirn, sdirn) + sd = inprod(sdirn, d) + if (dd <= 0 .or. ss <= EPS * delta**2 .or. is_nan(sd)) then + exit + end if + ! SQRTD: square root of a discriminant. The MAXVAL avoids SQRTD < ABS(SD) due to underflow. + sqrtd = maxval([sqrt(ss * dd + sd**2), abs(sd), sqrt(ss * dd)]) + if (sd > 0) then + step = dd / (sqrtd + sd) + else + step = (sqrtd - sd) / ss + end if + ! STEP < 0 should not happen. STEP can be 0 or NaN when, e.g., SD or SS becomes Inf. + if (step <= 0 .or. .not. is_finite(step)) then + exit + end if + ! Powell's approach and comments are as follows. + !----------------------------------------------------------------! + ! The two statements below that include the factor EPS prevent + ! some harmless underflows that occurred in a test calculation + ! (Zaikun: here, EPS is the machine epsilon; Powell's original + ! code used 1.0E-6, and Powell's code was written in SINGLE + ! PRECISION). Further, we skip the step if it could be zero within + ! a reasonable tolerance for computer rounding errors. + ! + ! !dd = delta**2 - sum(d**2, mask=(abs(d) >= EPS * delta)) + ! !ss = inprod(sdirn, sdirn) + ! !if (dd <= 0) then + ! ! exit + ! !end if + ! !sd = inprod(sdirn, d) + ! !if (abs(sd) >= EPS * sqrt(ss * dd)) then + ! ! step = dd / (sqrt(ss * dd + sd**2) + sd) + ! !else + ! ! step = dd / (sqrt(ss * dd) + sd) + ! !end if + !----------------------------------------------------------------! + !----------------------------------------------------------------------------------------------! + + if (stage == 1) then + if (isminor(cviol, step)) then + exit + end if + step = min(step, cviol) + end if + + ! Set DNEW to the new variables if STEP is the steplength, and reduce CVIOL to the corresponding + ! maximum residual if stage 1 is being done. + dnew = d + step * sdirn + if (stage == 1) then + !cvold = cviol + cviol = maximum([ZERO, matprod(dnew, A(:, iact(1:nact))) - b(iact(1:nact))]) + ! N.B.: CVIOL will be used when calculating VMULTD(NACT+1 : MCON). + end if + + ! Zaikun 20211011: + ! 1. VMULTD is computed from scratch for the second (out of 2) time in one iteration. + ! 2. VMULTD(1:NACT) and VMULTD(NACT+1:MCON) are calculated separately with no coupling. + ! 3. VMULTD will be calculated from scratch again in the next iteration. + ! Set VMULTD to the VMULTC vector that would occur if D became DNEW. A device is included to + ! force VMULTD(K)=ZERO if deviations from this value can be attributed to computer rounding + ! errors. First calculate the new Lagrange multipliers. + vmultd(1:nact) = -lsqr(A(:, iact(1:nact)), dnew, z(:, 1:nact), zdota(1:nact)) + if (stage == 2) then + vmultd(nact) = max(ZERO, vmultd(nact)) ! This seems never activated. + end if + ! Complete VMULTD by finding the new constraint residuals. (Powell wrote "Complete VMULTC ...") + cvshift = cviol - (matprod(dnew, A(:, iact)) - b(iact)) ! Only CVSHIFT(nact+1:mcon) is needed. + cvsabs = matprod(abs(dnew), abs(A(:, iact))) + abs(b(iact)) + cviol + cvshift(trueloc(isminor(cvshift, cvsabs))) = ZERO + !!MATLAB: cvshift(isminor(cvshift, cvsabs)) = 0; + vmultd(nact + 1:mcon) = cvshift(nact + 1:mcon) + + ! Calculate the fraction of the step from D to DNEW that will be taken. + fracmult = REALMAX + where (vmultd < 0) fracmult = vmultc / (vmultc - vmultd) + !!MATLAB: mask = (vmultd < 0); fracmult(mask) = vmultc(mask) / (vmultc(mask) - vmultd(mask)); + ! Only the places with VMULTD < 0 is relevant below, if any. + icon = int(minloc([ONE, fracmult], dim=1) - 1, kind(icon)) + frac = minval([ONE, fracmult]) + !!MATLAB: [frac, icon] = min([1, fracmult]); icon = icon - 1 + + ! Update D, VMULTC and CVIOL. + dold = d + d = (ONE - frac) * d + frac * dnew + vmultc = max(ZERO, (ONE - frac) * vmultc + frac * vmultd) + ! Exit in case of Inf/NaN in D or VMULTC. + if (.not. (is_finite(sum(abs(d))) .and. is_finite(sum(abs(vmultc))))) then + d = dold ! Should we restore also IACT, NACT, VMULTC, and Z? + exit + end if + + if (stage == 1) then + !cviol = (ONE - frac) * cvold + frac * cviol ! Powell's version + ! In theory, CVIOL = MAXVAL([MATPROD(D, A) - B, ZERO]), yet the CVIOL updated as above + ! can be quite different from this value if A has huge entries (e.g., > 1E20). + cviol = maximum([ZERO, matprod(d, A) - b]) + end if + + if (icon < 1 .or. icon > mcon) then + ! In Powell's code, the condition is ICON == 0. Indeed, ICON < 0 cannot hold unless + ! FRACMULT contains only NaN, which should not happen; ICON > MCON should never occur. + exit + end if +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(iact) == mcon, 'SIZE(IACT) == MCON', srname) + call assert(size(vmultc) == mcon, 'SIZE(VMULTC) == MCON', srname) + call assert(precision(0.0_RP) < precision(0.0D0) .or. all(vmultc >= 0), 'VMULTC >= 0', srname) + call assert(size(d) == n, 'SIZE(D) == N', srname) + call assert(all(is_finite(d)), 'D is finite', srname) + call assert(norm(d) <= TWO * delta, '||D|| <= 2*DELTA', srname) + call assert(size(z, 1) == n .and. size(z, 2) == n, 'SIZE(Z) == [N, N]', srname) + call assert(nact >= 0 .and. nact <= min(mcon, n), '0 <= NACT <= MIN(MCON, N)', srname) +end if + +end subroutine trstlp_sub + + +function trrad(delta_in, dnorm, eta1, eta2, gamma1, gamma2, ratio) result(delta) +!--------------------------------------------------------------------------------------------------! +! This function updates the trust region radius according to RATIO and DNORM. +!--------------------------------------------------------------------------------------------------! + +! Generic module +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan +use, non_intrinsic :: debug_mod, only : assert + +implicit none + +! Input +real(RP), intent(in) :: delta_in ! Current trust-region radius +real(RP), intent(in) :: dnorm ! Norm of current trust-region step +real(RP), intent(in) :: eta1 ! Ratio threshold for contraction +real(RP), intent(in) :: eta2 ! Ratio threshold for expansion +real(RP), intent(in) :: gamma1 ! Contraction factor +real(RP), intent(in) :: gamma2 ! Expansion factor +real(RP), intent(in) :: ratio ! Reduction ratio + +! Outputs +real(RP) :: delta + +! Local variables +character(len=*), parameter :: srname = 'TRRAD' + +! Preconditions +if (DEBUGGING) then + call assert(delta_in >= dnorm .and. dnorm > 0, 'DELTA_IN >= DNORM > 0', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + ! By the definition of RATIO in ratio.f90, RATIO cannot be NaN unless the actual reduction is + ! NaN, which should NOT happen due to the moderated extreme barrier. + call assert(.not. is_nan(ratio), 'RATIO is not NaN', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (ratio <= eta1) then + delta = gamma1 * dnorm ! Powell's UOBYQA/NEWUOA. + !delta = gamma1 * delta_in ! Powell's COBYLA/LINCOA. + !delta = min(gamma1 * delta_in, dnorm) ! Powell's BOBYQA. +elseif (ratio <= eta2) then + delta = max(gamma1 * delta_in, dnorm) ! Powell's UOBYQA/NEWUOA/BOBYQA/LINCOA +else + delta = max(gamma1 * delta_in, gamma2 * dnorm) ! Powell's NEWUOA/BOBYQA. + !delta = max(delta_in, gamma2 * dnorm) ! Modified version. Works well for UOBYQA. + ! For noise-free CUTEst problems of <= 100 variables, Powell's version works slightly better + ! than the modified one. + !delta = max(delta_in, 1.25_RP * dnorm, dnorm + rho) ! Powell's UOBYQA. + !delta = min(max(gamma1 * delta_in, gamma2 * dnorm), sqrt(gamma2) * delta_in) ! Powell's LINCOA. +end if + +! For noisy problems, the following may work better. +! !if (ratio <= eta1) then +! ! delta = gamma1 * dnorm +! !elseif (ratio <= eta2) then ! Ensure DELTA >= DELTA_IN +! ! delta = delta_in +! !else ! Ensure DELTA > DELTA_IN with a constant factor +! ! delta = max(delta_in * (1.0_RP + gamma2) / 2.0_RP, gamma2 * dnorm) +! !end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(delta > 0, 'DELTA > 0', srname) +end if + +end function trrad + + +end module trustregion_cobyla_mod diff --git a/examples/fortran/prima/native/cobyla/update.f90 b/examples/fortran/prima/native/cobyla/update.f90 new file mode 100644 index 000000000..642331a5d --- /dev/null +++ b/examples/fortran/prima/native/cobyla/update.f90 @@ -0,0 +1,407 @@ +module update_cobyla_mod +!--------------------------------------------------------------------------------------------------! +! This module contains subroutines concerning the update of the interpolation set. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the COBYLA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2021 +! +! Last Modified: Thu 14 Aug 2025 07:34:04 AM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: updatexfc, updatepole, findpole + + +contains + + +subroutine updatexfc(jdrop, constr, cpen, cstrv, d, f, conmat, cval, fval, sim, simi, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine revises the simplex by updating the elements of SIM, SIMI, FVAL, CONMAT, and CVAL. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : IK, RP, ONE, TENTH, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, DAMAGING_ROUNDING +use, non_intrinsic :: linalg_mod, only : matprod, inprod, outprod, maximum, eye, inv, isinv +use, non_intrinsic :: debug_mod, only : assert + +implicit none + +! Inputs +integer(IK), intent(in) :: jdrop +real(RP), intent(in) :: constr(:) ! CONSTR(M) +real(RP), intent(in) :: cpen +real(RP), intent(in) :: cstrv +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: f + +! In-outputs +real(RP), intent(inout) :: conmat(:, :) ! CONMAT(M, N+1) +real(RP), intent(inout) :: cval(:) ! CVAL(N+1) +real(RP), intent(inout) :: fval(:) ! FVAL(N+1) +real(RP), intent(inout) :: sim(:, :)! SIM(N, N+1) +real(RP), intent(inout) :: simi(:, :) ! SIMI(N, N) + +! Outputs +integer(IK), intent(out) :: info + +! Local variables +character(len=*), parameter :: srname = 'UPDATEXFC' +integer(IK) :: m +integer(IK) :: n +real(RP) :: erri +real(RP) :: erri_test +real(RP) :: sim_old(size(sim, 1), size(sim, 2)) +real(RP) :: simi_jdrop(size(simi, 2)) +real(RP) :: simi_old(size(simi, 1), size(simi, 2)) +real(RP) :: simi_test(size(simi, 1), size(simi, 2)) +real(RP) :: simid(size(simi, 1)) +real(RP) :: sum_simi(size(simi, 2)) +real(RP), parameter :: itol = ONE + +! Sizes +m = int(size(constr), kind(m)) +n = int(size(sim, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(jdrop >= 0 .and. jdrop <= n + 1, '1 <= JDROP <= N+1', srname) + call assert(.not. any(is_nan(constr) .or. is_posinf(constr)), 'CONSTR does not contain NaN/+Inf', srname) + call assert(.not. (is_nan(cstrv) .or. is_posinf(cstrv)), 'CSTRV is not NaN/+Inf', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(conmat, 1) == m .and. size(conmat, 2) == n + 1, 'SIZE(CONMAT) = [M, N+1]', srname) + call assert(.not. any(is_nan(conmat) .or. is_posinf(conmat)), 'CONMAT does not contain NaN/+Inf', srname) + call assert(size(cval) == n + 1 .and. .not. any(cval < 0 .or. is_nan(cval) .or. is_posinf(cval)), & + & 'SIZE(CVAL) == N+1 and CVAL does not contain negative values or NaN/+Inf', srname) + call assert(size(fval) == n + 1 .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == N+1 and FVAL is not NaN/+Inf', srname) + call assert(size(sim, 1) == n .and. size(sim, 2) == n + 1, 'SIZE(SIM) == [N, N+1]', srname) + call assert(all(is_finite(sim)), 'SIM is finite', srname) + call assert(all(sum(abs(sim(:, 1:n)), dim=1) > 0), 'SIM(:, 1:N) has no zero column', srname) + call assert(size(simi, 1) == n .and. size(simi, 2) == n, 'SIZE(SIMI) == [N, N]', srname) + call assert(all(is_finite(simi)), 'SIMI is finite', srname) + call assert(isinv(sim(:, 1:n), simi, itol), 'SIMI = SIM(:, 1:N)^{-1}', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Do nothing when JDROP is 0. This can only happen after a trust-region step. +if (jdrop <= 0) then ! JDROP < 0 is impossible if the input is correct. + info = INFO_DFT ! INFO must be set, as it is an output! + return +end if + +sim_old = sim +simi_old = simi +! N.B.: The use of OUTPROD is expensive memory-wise, but it is not our concern in this implementation. +if (jdrop <= n) then + sim(:, jdrop) = d + simi_jdrop = simi(jdrop, :) / inprod(simi(jdrop, :), d) + simi = simi - outprod(matprod(simi, d), simi_jdrop) + simi(jdrop, :) = simi_jdrop +else ! JDROP = N+1 + sim(:, n + 1) = sim(:, n + 1) + d + sim(:, 1:n) = sim(:, 1:n) - spread(d, dim=2, ncopies=n) + simid = matprod(simi, d) + sum_simi = sum(simi, dim=1) + simi = simi + outprod(simid, sum_simi / (ONE - sum(simid))) +end if + +! Check whether SIMI is a poor approximation to the inverse of SIM(:, 1:N). +! Calculate SIMI from scratch if the current one is damaged by rounding errors. +erri = maximum(abs(matprod(simi, sim(:, 1:n)) - eye(n))) ! MAXIMUM(X) returns NaN if X contains NaN +if (erri > TENTH * itol .or. is_nan(erri)) then + simi_test = inv(sim(:, 1:n)) + erri_test = maximum(abs(matprod(simi_test, sim(:, 1:n)) - eye(n))) + if (erri_test < erri .or. (is_nan(erri) .and. .not. is_nan(erri_test))) then + simi = simi_test + erri = erri_test + end if +end if + +! If SIMI is satisfactory, then update FVAL, CONMAT, CVAL, and the pole position. Otherwise, restore +! SIM and SIMI, and return with INFO = DAMAGING_ROUNDING. +if (erri <= itol) then + fval(jdrop) = f + conmat(:, jdrop) = constr + cval(jdrop) = cstrv + ! Switch the best vertex to the pole position SIM(:, N+1) if it is not there already. + call updatepole(cpen, conmat, cval, fval, sim, simi, info) +else ! ERRI > ITOL or ERRI is NaN + info = DAMAGING_ROUNDING + sim = sim_old + simi = simi_old +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(conmat, 1) == m .and. size(conmat, 2) == n + 1, 'SIZE(CONMAT) = [M, N+1]', srname) + call assert(.not. any(is_nan(conmat) .or. is_posinf(conmat)), 'CONMAT does not contain NaN/+Inf', srname) + call assert(size(cval) == n + 1 .and. .not. any(cval < 0 .or. is_nan(cval) .or. is_posinf(cval)), & + & 'SIZE(CVAL) == N+1 and CVAL does not contain negative values or NaN/+Inf', srname) + call assert(size(fval) == n + 1 .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == N+1 and FVAL is not NaN/+Inf', srname) + call assert(size(sim, 1) == n .and. size(sim, 2) == n + 1, 'SIZE(SIM) == [N, N+1]', srname) + call assert(all(is_finite(sim)), 'SIM is finite', srname) + call assert(all(sum(abs(sim(:, 1:n)), dim=1) > 0), 'SIM(:, 1:N) has no zero column', srname) + call assert(size(simi, 1) == n .and. size(simi, 2) == n, 'SIZE(SIMI) == [N, N]', srname) + call assert(all(is_finite(simi)), 'SIMI is finite', srname) + call assert(isinv(sim(:, 1:n), simi, itol) .or. info == DAMAGING_ROUNDING, & + & 'SIMI = SIM(:, 1:N)^{-1} unless the rounding is damaging', srname) +end if +end subroutine updatexfc + + +subroutine updatepole(cpen, conmat, cval, fval, sim, simi, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine identifies the best vertex of the current simplex with respect to the merit +! function PHI = F + CPEN * CSTRV, and then switch this vertex to SIM(:, N + 1), which Powell called +! the "pole position" in his comments. CONMAT, CVAL, FVAL, and SIMI are updated accordingly. +! +! N.B. 1: In precise arithmetic, the following two procedures produce the same results: +! 1) apply UPDATEPOLE to SIM twice, first with CPEN = CPEN1 and then with CPEN = CPEN2; +! 2) apply UPDATEPOLE to SIM with CPEN = CPEN2. +! In finite-precision arithmetic, however, they may produce different results unless CPEN1 = CPEN2. +! +! N.B. 2: When JOPT == N+1, the best vertex is already at the pole position, so there is nothing to +! switch. However, as in Powell's code, the code below will check whether SIMI is good enough to +! work as the inverse of SIM(:, 1:N) or not. If not, Powell's code would invoke an error return of +! COBYLB; our implementation, however, will try calculating SIMI from scratch; if the recalculated +! SIMI is still of poor quality, then UPDATEPOLE will return with INFO = DAMAGING_ROUNDING, +! informing COBYLB that SIMI is poor due to damaging rounding errors. +! +! N.B. 3: UPDATEPOLE should be called when and only when FINDPOLE can potentially returns a value +! other than N+1. The value of FINDPOLE is determined by CPEN, CVAL, and FVAL, the latter two being +! decided by SIM. Thus UPDATEPOLE should be called after CPEN or SIM changes. COBYLA updates CPEN at +! only two places: the beginning of each trust-region iteration, and when REDRHO is called; +! SIM is updated only by UPDATEXFC, which itself calls UPDATEPOLE internally. Therefore, we only +! need to call UPDATEPOLE after updating CPEN at the beginning of each trust-region iteration and +! after each invocation of REDRHO. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : IK, RP, ZERO, ONE, TENTH, DEBUGGING +use, non_intrinsic :: infos_mod, only : DAMAGING_ROUNDING, INFO_DFT +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: linalg_mod, only : matprod, eye, inv, isinv, maximum + +implicit none + +! Inputs +real(RP), intent(in) :: cpen + +! In-outputs +real(RP), intent(inout) :: conmat(:, :) ! CONMAT(M, N+1) +real(RP), intent(inout) :: cval(:) ! CVAL(N+1) +real(RP), intent(inout) :: fval(:) ! FVAL(N+1) +real(RP), intent(inout) :: sim(:, :)! SIM(N, N+1) +real(RP), intent(inout) :: simi(:, :) ! SIMI(N, N) + +! Outputs +integer(IK), intent(out) :: info + +! Local variables +character(len=*), parameter :: srname = 'UPDATEPOLE' +integer(IK) :: jopt +integer(IK) :: m +integer(IK) :: n +real(RP) :: erri +real(RP) :: erri_test +real(RP) :: sim_jopt(size(sim, 1)) +real(RP) :: sim_old(size(sim, 1), size(sim, 2)) +real(RP) :: simi_old(size(simi, 1), size(simi, 2)) +real(RP) :: simi_test(size(simi, 1), size(simi, 2)) +real(RP), parameter :: itol = ONE + +! Sizes +m = int(size(conmat, 1), kind(m)) +n = int(size(sim, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(cpen > 0, 'CPEN > 0', srname) + call assert(size(conmat, 1) == m .and. size(conmat, 2) == n + 1, 'SIZE(CONMAT) = [M, N+1]', srname) + call assert(.not. any(is_nan(conmat) .or. is_posinf(conmat)), 'CONMAT does not contain NaN/+Inf', srname) + call assert(size(cval) == n + 1 .and. .not. any(cval < 0 .or. is_nan(cval) .or. is_posinf(cval)), & + & 'SIZE(CVAL) == N+1 and CVAL does not contain negative values or NaN/+Inf', srname) + call assert(size(fval) == n + 1 .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == N+1 and FVAL is not NaN/+Inf', srname) + call assert(size(sim, 1) == n .and. size(sim, 2) == n + 1, 'SIZE(SIM) == [N, N+1]', srname) + call assert(all(is_finite(sim)), 'SIM is finite', srname) + call assert(all(sum(abs(sim(:, 1:n)), dim=1) > 0), 'SIM(:, 1:N) has no zero column', srname) + call assert(size(simi, 1) == n .and. size(simi, 2) == n, 'SIZE(SIMI) == [N, N]', srname) + call assert(all(is_finite(simi)), 'SIMI is finite', srname) + call assert(isinv(sim(:, 1:n), simi, itol), 'SIMI = SIM(:, 1:N)^{-1}', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! INFO must be set, as it is an output. +info = INFO_DFT + +! Identify the optimal vertex of the current simplex. +jopt = findpole(cpen, cval, fval) + +! Switch the best vertex to the pole position SIM(:, N+1) if it is not there already, and update +! SIMI. Before the update, save a copy of SIM and SIMI. If the update is unsuccessful due to +! damaging rounding errors, we restore them and return with INFO = DAMAGING_ROUNDING. +sim_old = sim +simi_old = simi +if (jopt >= 1 .and. jopt <= n) then + ! Unless there is a bug in FINDPOLE, it is guaranteed that JOPT >= 1. + ! When JOPT == N + 1, there is nothing to switch; in addition, SIMI(JOPT, :) will be illegal. + sim(:, n + 1) = sim(:, n + 1) + sim(:, jopt) + sim_jopt = sim(:, jopt) + sim(:, jopt) = ZERO + sim(:, 1:n) = sim(:, 1:n) - spread(sim_jopt, dim=2, ncopies=n) + !!MATLAB: sim(:, 1:n) = sim(:, 1:n) - sim_jopt; % sim_jopt should be a column! Implicit expansion + ! The above update is equivalent to multiply SIM(:, 1:N) from the right side by a matrix whose + ! JOPT-th row is [-1, -1, ..., -1], while all the other rows are the same as those of the + ! identity matrix. It is easy to check that the inverse of this matrix is itself. Therefore, + ! SIMI should be updated by a multiplication with this matrix (i.e., its inverse) from the left + ! side, as is done in the following line. The JOPT-th row of the updated SIMI is minus the sum + ! of all rows of the original SIMI, whereas all the other rows remain unchanged. + simi(jopt, :) = -sum(simi, dim=1) ! Must ensure that 1 <= JOPT <= N! +end if + +! Check whether SIMI is a poor approximation to the inverse of SIM(:, 1:N). +! Calculate SIMI from scratch if the current one is damaged by rounding errors. +erri = maximum(abs(matprod(simi, sim(:, 1:n)) - eye(n))) ! MAXIMUM(X) returns NaN if X contains NaN +if (erri > TENTH * itol .or. is_nan(erri)) then + simi_test = inv(sim(:, 1:n)) + erri_test = maximum(abs(matprod(simi_test, sim(:, 1:n)) - eye(n))) + if (erri_test < erri .or. (is_nan(erri) .and. .not. is_nan(erri_test))) then + simi = simi_test + erri = erri_test + end if +end if + +! If SIMI is satisfactory, then update FVAL, CONMAT, and CVAL. Otherwise, restore SIM and SIMI, and +! return with INFO = DAMAGING_ROUNDING. +if (erri <= itol) then + if (jopt >= 1 .and. jopt <= n) then + fval([jopt, n + 1_IK]) = fval([n + 1_IK, jopt]) + conmat(:, [jopt, n + 1_IK]) = conmat(:, [n + 1_IK, jopt]) + cval([jopt, n + 1_IK]) = cval([n + 1_IK, jopt]) + end if +else ! ERRI > ITOL or ERRI is NaN + info = DAMAGING_ROUNDING + sim = sim_old + simi = simi_old +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(findpole(cpen, cval, fval) == n + 1 .or. info == DAMAGING_ROUNDING, & + & 'The best point is SIM(:, N+1) unless the rounding is damaging', srname) + call assert(size(conmat, 1) == m .and. size(conmat, 2) == n + 1, 'SIZE(CONMAT) = [M, N+1]', srname) + call assert(.not. any(is_nan(conmat) .or. is_posinf(conmat)), 'CONMAT does not contain NaN/+Inf', srname) + call assert(size(cval) == n + 1 .and. .not. any(cval < 0 .or. is_nan(cval) .or. is_posinf(cval)), & + & 'SIZE(CVAL) == N+1 and CVAL does not contain negative values or NaN/+Inf', srname) + call assert(size(fval) == n + 1 .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == N+1 and FVAL is not NaN/+Inf', srname) + call assert(size(sim, 1) == n .and. size(sim, 2) == n + 1, 'SIZE(SIM) == [N, N+1]', srname) + call assert(all(is_finite(sim)), 'SIM is finite', srname) + call assert(all(sum(abs(sim(:, 1:n)), dim=1) > 0), 'SIM(:, 1:N) has no zero column', srname) + call assert(size(simi, 1) == n .and. size(simi, 2) == n, 'SIZE(SIMI) == [N, N]', srname) + call assert(all(is_finite(simi)), 'SIMI is finite', srname) + ! Do not check SIMI = SIM(:, 1:N)^{-1}, as it may not be true due to damaging rounding. + call assert(isinv(sim(:, 1:n), simi, itol) .or. info == DAMAGING_ROUNDING, & + & 'SIMI = SIM(:, 1:N)^{-1} unless the rounding is damaging', srname) +end if + +end subroutine updatepole + + +function findpole(cpen, cval, fval) result(jopt) +!--------------------------------------------------------------------------------------------------! +! This subroutine identifies the best vertex of the current simplex with respect to the merit +! function PHI = F + CPEN * CSTRV. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : IK, RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf + +implicit none + +! Inputs +real(RP), intent(in) :: cpen +real(RP), intent(in) :: cval(:) ! CVAL(N+1) +real(RP), intent(in) :: fval(:) ! FVAL(N+1) + +! Outputs +integer(IK) :: jopt + +! Local variables +character(len=*), parameter :: srname = 'FINDPOLE' +integer(IK) :: n +real(RP) :: phi(size(cval)) +real(RP) :: phimin + +! Size +n = int(size(fval) - 1, kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(cpen > 0, 'CPEN > 0', srname) + call assert(size(cval) == n + 1 .and. .not. any(cval < 0 .or. is_nan(cval) .or. is_posinf(cval)), & + & 'SIZE(CVAL) == N+1 and CVAL does not contain negative values or NaN/+Inf', srname) + call assert(size(fval) == n + 1 .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == N+1 and FVAL is not NaN/+Inf', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Identify the optimal vertex of the current simplex. +jopt = int(size(fval), kind(jopt)) ! We use N + 1 as the default value of JOPT. +phi = fval + cpen * cval +phimin = minval(phi) +! Essentially, JOPT = MINLOC(PHI). However, we keep JOPT = N + 1 unless there is a strictly better +! choice. When there are multiple choices, we choose the JOPT with the smallest value of CVAL. +if (phimin < phi(jopt) .or. any(cval < cval(jopt) .and. phi <= phi(jopt))) then + jopt = int(minloc(cval, mask=(phi <= phimin), dim=1), kind(jopt)) + !!MATLAB: cmin = min(cval(phi <= phimin)); jopt = find(phi <= phimin & cval <= cmin, 1, 'first'); +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(jopt >= 1 .and. jopt <= n + 1, '1 <= JOPT <= N+1', srname) + call assert(jopt == n + 1 .or. phi(jopt) < phi(n + 1) .or. (phi(jopt) <= phi(n + 1) .and. cval(jopt) < cval(n + 1)), & + & 'JOPT = N+1 unless PHI(JOPT) < PHI(N+1) or PHI(JOPT) <= PHI(N+1) and CVAL(JOPT) < CVAL(N+1)', srname) +end if +end function findpole + + +end module update_cobyla_mod diff --git a/examples/fortran/prima/native/common/checkexit.f90 b/examples/fortran/prima/native/common/checkexit.f90 new file mode 100644 index 000000000..02b5de11f --- /dev/null +++ b/examples/fortran/prima/native/common/checkexit.f90 @@ -0,0 +1,178 @@ +!TODO: merge CHECKEXIT_UNC and CHECKEXIT_CON, using optional CSTRV and CTOL. +module checkexit_mod +!--------------------------------------------------------------------------------------------------! +! This module checks whether to exit the solver. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: September 2021 +! +! Last Modified: Tuesday, September 26, 2023 AM10:51:16 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: checkexit + +interface checkexit + module procedure checkexit_unc, checkexit_con +end interface checkexit + + +contains + + +function checkexit_unc(maxfun, nf, f, ftarget, x) result(info) +!--------------------------------------------------------------------------------------------------! +! This module checks whether to exit the solver in the unconstrained case. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_inf +use, non_intrinsic :: infos_mod, only : INFO_DFT, NAN_INF_X, NAN_INF_F, FTARGET_ACHIEVED, MAXFUN_REACHED + +implicit none + +! Inputs +integer(IK), intent(in) :: maxfun +integer(IK), intent(in) :: nf +real(RP), intent(in) :: f +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: x(:) + +! Outputs +integer(IK) :: info + +! Local variables +character(len=*), parameter :: srname = 'CHECKEXIT_UNC' + +! Preconditions +if (DEBUGGING) then + call assert(.not. any([NAN_INF_X, NAN_INF_F, FTARGET_ACHIEVED, MAXFUN_REACHED] == INFO_DFT), & + & 'NAN_INF_X, NAN_INF_F, FTARGET_ACHIEVED, and MAXFUN_REACHED differ from INFO_DFT', srname) + ! X does not contain NaN if the initial X does not contain NaN and the subroutines generating + ! trust-region/geometry steps work properly so that they never produce a step containing NaN/Inf. + call assert(.not. any(is_nan(x)), 'X does not contain NaN', srname) + ! With the moderated extreme barrier, F cannot be NaN/+Inf. + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +info = INFO_DFT ! Default info, indicating that the solver should not exit. + +! Although X should not contain NaN unless there is a bug, we include the following for security. +! X can be Inf, as finite + finite can be Inf numerically. +if (any(is_nan(x) .or. is_inf(x))) then + info = NAN_INF_X +end if + +! Although NAN_INF_F should not happen unless there is a bug, we include the following for security. +if (is_nan(f) .or. is_posinf(f)) then + info = NAN_INF_F +end if + +if (f <= ftarget) then + info = FTARGET_ACHIEVED +end if + +if (nf >= maxfun) then + info = MAXFUN_REACHED +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(any([INFO_DFT, NAN_INF_X, FTARGET_ACHIEVED, MAXFUN_REACHED] == info), & + & 'INFO is NAN_INF_X, FTARGET_ACHIEVED, MAXFUN_REACHED, or INFO_DFT', srname) +end if + +end function checkexit_unc + + +function checkexit_con(maxfun, nf, cstrv, ctol, f, ftarget, x) result(info) +!--------------------------------------------------------------------------------------------------! +! This module checks whether to exit the solver in the constrained case. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_inf +use, non_intrinsic :: infos_mod, only : INFO_DFT, NAN_INF_X, NAN_INF_F, FTARGET_ACHIEVED, MAXFUN_REACHED + +implicit none + +! Inputs +integer(IK), intent(in) :: maxfun +integer(IK), intent(in) :: nf +real(RP), intent(in) :: cstrv +real(RP), intent(in) :: ctol +real(RP), intent(in) :: f +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: x(:) + +! Outputs +integer(IK) :: info + +! Local variables +character(len=*), parameter :: srname = 'CHECKEXIT_CON' + +! Preconditions +if (DEBUGGING) then + call assert(.not. any([NAN_INF_X, NAN_INF_F, FTARGET_ACHIEVED, MAXFUN_REACHED] == INFO_DFT), & + & 'NAN_INF_X, NAN_INF_F, FTARGET_ACHIEVED, and MAXFUN_REACHED differ from INFO_DFT', srname) + ! X does not contain NaN if the initial X does not contain NaN and the subroutines generating + ! trust-region/geometry steps work properly so that they never produce a step containing NaN/Inf. + call assert(.not. any(is_nan(x)), 'X does not contain NaN', srname) + ! With the moderated extreme barrier, F or CSTRV cannot be NaN/+Inf. + call assert(.not. (is_nan(f) .or. is_posinf(f) .or. is_nan(cstrv) .or. is_posinf(cstrv)), & + & 'F or CSTRV is not NaN/+Inf', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +info = INFO_DFT ! Default info, indicating that the solver should not exit. + +! Although X should not contain NaN unless there is a bug, we include the following for security. +! X can be Inf, as finite + finite can be Inf numerically. +if (any(is_nan(x) .or. is_inf(x))) then + info = NAN_INF_X +end if + +! Although NAN_INF_F should not happen unless there is a bug, we include the following for security. +if (is_nan(f) .or. is_posinf(f) .or. is_nan(cstrv) .or. is_posinf(cstrv)) then + info = NAN_INF_F +end if + +if (cstrv <= ctol .and. f <= ftarget) then + info = FTARGET_ACHIEVED +end if + +if (nf >= maxfun) then + info = MAXFUN_REACHED +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(any([INFO_DFT, NAN_INF_F, FTARGET_ACHIEVED, MAXFUN_REACHED] == info), & + & 'INFO is NAN_INF_X, FTARGET_ACHIEVED, MAXFUN_REACHED, or INFO_DFT', srname) +end if + +end function checkexit_con + + +end module checkexit_mod diff --git a/examples/fortran/prima/native/common/consts.F90 b/examples/fortran/prima/native/common/consts.F90 new file mode 100644 index 000000000..c1d31b3ce --- /dev/null +++ b/examples/fortran/prima/native/common/consts.F90 @@ -0,0 +1,266 @@ +#include "ppf.h" + +module consts_mod +!--------------------------------------------------------------------------------------------------! +! This is a module defining some constants. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020 +! +! Last Modified: Mon 16 Feb 2026 03:39:56 PM CET +!--------------------------------------------------------------------------------------------------! + +!--------------------------------------------------------------------------------------------------! +! Remarks: +! +! 1. REAL*4, REAL*8, INTEGER*4, INTEGER*8 are not Fortran standard expressions. Do not use them! +! +! 2. Never use KIND with a literal value, e.g., REAL(KIND = 8), because Fortran standards never +! define what KIND = 8 means. There is NO guarantee that REAL(KIND = 8) will be legal, let alone +! being double precision. +! +! 3. Fortran standard (as of F2018) specifies the following for types INTEGER and REAL. +! +! - A processor shall provide ONE OR MORE representation methods that define sets of values for +! data of type integer; if the kind type parameter is not specified, the default kind value is +! KIND(0) and the type specified is DEFAULT INTEGER. +! - A processor shall provide TWO OR MORE approximation methods that define sets of values for +! data of type real; if the type keyword REAL is specified and the kind type parameter is not +! specified, the default kind value is KIND (0.0) and the type specified is DEFAULT REAL; If the +! type keyword DOUBLE PRECISION is specified, the kind value is KIND (0.0D0) and the type +! specified is DOUBLE PRECISION real; the decimal precision of the double precision real +! approximation method shall be greater than that of the default real method. +! - Default integer, default real, and default logical all occupy one storage unit. Double +! precision and complex occupy two storage units and double complex requires four storage units. +! +! In other words, the standard only imposes that the following three types should be supported: +! - INTEGER(KIND(0)), i.e., default integer, +! - REAL(KIND(0.0)), i.e., default real (single-precision real), +! - REAL(KIND(0.0D0)), i.e., double-precision real. +! +! Moreover, the following should be noted. +! +! - Other types of INTEGER/REAL may not be available on all platforms (e.g., nvfortran 23.3 and +! flang 15.0.3 do not support REAL128). +! - The standard does not specify the range of the default integer. However, if the default real +! occupies 32 bits, which is normally the case, then the default integer occupies also 32 bits, +! and hence the range is probably [-2^32, 2^31-1], approximately [-2*10^9, 2*10^9]. +! - The standard does not specify what the range and precision of the default real or the +! double-precision real, except that KIND(0.0D0) should have a greater precision than KIND(0.0) +! --- no requirement about the range. +! +! Consequently, the following should be observed in all Fortran code. +! +! - DO NOT use any kind parameter other than IK, IK_DFT, RP, RP_DFT, SP, or DP, unless you are +! sure that it is supported by your platform. +! - DO NOT make any assumption on the range of INTEGER, REAL, or REAL(0.0D0) unless you are sure. +! - Be cautious about OVERFLOW! In particular, for integers working as the lower/upper limit of +! arrays, overflow can lead to Segmentation Faults! +!--------------------------------------------------------------------------------------------------! + +! Integer and real kinds. Unsupported kinds are negative. +use, intrinsic :: iso_fortran_env, only : INT16, INT32, INT64, SP => REAL32, DP => REAL64 +#if PRIMA_HP_AVAILABLE == 1 +use, intrinsic :: iso_fortran_env, only : HP => REAL16 +#endif +#if PRIMA_QP_AVAILABLE == 1 +use, intrinsic :: iso_fortran_env, only : QP => REAL128 +#endif + +! Standard IO units +use, intrinsic :: iso_fortran_env, only : STDIN => INPUT_UNIT, STDOUT => OUTPUT_UNIT, STDERR => ERROR_UNIT + +implicit none + +private +public :: DEBUGGING +public :: IK, IK_DFT, INT16, INT32, INT64 +public :: RP, RP_DFT, DP, SP +#if PRIMA_HP_AVAILABLE == 1 +public :: HP +#endif +#if PRIMA_QP_AVAILABLE == 1 +public :: QP +#endif +public :: ZERO, ONE, TWO, HALF, QUART, TEN, TENTH, PI +public :: REALMIN, EPS, MAXPOW10, TINYCV, REALMAX, FUNCMAX, CONSTRMAX, BOUNDMAX +public :: SYMTOL_DFT, ORTHTOL_DFT +public :: STDIN, STDOUT, STDERR +public :: RHOBEG_DFT, RHOEND_DFT, FTARGET_DFT, CTOL_DFT, CWEIGHT_DFT +public :: ETA1_DFT, ETA2_DFT, GAMMA1_DFT, GAMMA2_DFT +public :: MAXFUN_DIM_DFT, MAXHISTMEM, MIN_MAXFILT, MAXFILT_DFT, IPRINT_DFT + + +logical, parameter :: DEBUGGING = (PRIMA_DEBUGGING == 1) ! Whether we are in debugging mode +integer, parameter :: IK_DFT = kind(0) ! Default integer kind +integer, parameter :: RP_DFT = kind(0.0) ! Default real kind + +! Define the integer kind to be used in the Fortran code. +#if PRIMA_INTEGER_KIND == 0 +integer, parameter :: IK = IK_DFT +#elif PRIMA_INTEGER_KIND == 16 +integer, parameter :: IK = INT16 +#elif PRIMA_INTEGER_KIND == 32 +integer, parameter :: IK = INT32 +#elif PRIMA_INTEGER_KIND == 64 +integer, parameter :: IK = INT64 +#else +integer, parameter :: IK = IK_DFT +#endif + +! Define the real kind to be used in the Fortran code. +#if PRIMA_REAL_PRECISION == 0 +integer, parameter :: RP = RP_DFT +#elif (PRIMA_REAL_PRECISION == 16 && PRIMA_HP_AVAILABLE == 1) +integer, parameter :: RP = HP +#elif PRIMA_REAL_PRECISION == 32 +integer, parameter :: RP = SP +#elif PRIMA_REAL_PRECISION == 64 +integer, parameter :: RP = DP +#elif (PRIMA_REAL_PRECISION == 128 && PRIMA_QP_AVAILABLE == 1) +integer, parameter :: RP = QP +#else +integer, parameter :: RP = DP ! Double precision +#endif + +! Define some frequently used numbers. +real(RP), parameter :: ZERO = 0.0_RP +real(RP), parameter :: ONE = 1.0_RP +real(RP), parameter :: TWO = 2.0_RP +real(RP), parameter :: HALF = 0.5_RP +real(RP), parameter :: QUART = 0.25_RP +real(RP), parameter :: TEN = 10.0_RP +real(RP), parameter :: TENTH = 0.1_RP +real(RP), parameter :: PI = 3.1415926535897932384626433832795028841971693993751058209749445923078_RP + +! EPS is the machine epsilon, namely the smallest floating-point number such that 1.0 + EPS > 1.0. +real(RP), parameter :: EPS = epsilon(ZERO) +! REALMIN is the smallest positive normalized floating-point number, which is 2^(-1022) ~ 2.225E-308 +! for IEEE double precision. Taking double precision as an example, REALMIN in other languages: +! MATLAB: realmin or realmin('double') +! Python: numpy.finfo(numpy.float64).tiny +! Julia: realmin(Float64) +! R: double.xmin +real(RP), parameter :: REALMIN = tiny(ZERO) +! REALMAX is the largest positive floating-point number, which is 2^1023 * (2 - EPS) ~ 1.797E308 +! for IEEE double precision. Taking double precision as an example, REALMAX in other languages: +! MATLAB: realmax or realmax('double') +! Python: numpy.finfo(numpy.float64).max +! Julia: realmax(Float64) +! R: double.xmax +real(RP), parameter :: REALMAX = huge(ZERO) + +integer, parameter :: MAXPOW10 = range(ZERO) +integer, parameter :: HALF_MAXPOW10 = floor(real(MAXPOW10) / 2.0) + +! TINYCV is used in LINCOA. Powell set TINYCV = 1.0D-60. What about setting TINYCV = REALMIN? +! N.B.: The `if` is a workaround for the following issues with LLVM flang 19.0.0 and nvfortran 24.3.0: +! https://fortran-lang.discourse.group/t/flang-new-19-0-warning-overflow-on-power-with-integer-exponent/7801 +! https://forums.developer.nvidia.com/t/bug-of-nvfortran-24-3-0-fort1-terminated-by-signal-11/289026 +#if (defined __flang__ && __flang_major__ <= 19) +real(RP), parameter :: TINYCV = TEN**max(-60.0, -real(MAXPOW10)) +#else +real(RP), parameter :: TINYCV = TEN**max(-60, -MAXPOW10) +#endif +! FUNCMAX is used in the moderated extreme barrier. All function values are projected to the +! interval [-FUNCMAX, FUNCMAX] before passing to the solvers, and NaN is replaced with FUNCMAX. +! CONSTRMAX plays a similar role for constraints. +real(RP), parameter :: FUNCMAX = TEN**max(4, min(30, HALF_MAXPOW10)) +real(RP), parameter :: CONSTRMAX = FUNCMAX +! Any bound with an absolute value at least BOUNDMAX is considered as no bound. +real(RP), parameter :: BOUNDMAX = QUART * REALMAX + +! SYMTOL_DFT is the default tolerance for testing symmetry of matrices. It can be set to 0 if the +! IEEE Standard for Floating-Point Arithmetic (IEEE 754) is respected, particularly if addition and +! multiplication are commutative. However, as of 20220408, NAG nagfor does not ensure commutativity +! for REAL128. Indeed, Fortran standards do not enforce IEEE 754, so compilers are not guaranteed to +! respect it. Hence we set SYMTOL_DFT to a nonzero number when PRIMA_RELEASED is 1 (although we do not +! intend to test symmetry in production, it may be tested if PRIMA_DEBUGGING is set to 1). +! Update 20221226: When gfortran 12 is invoked with aggressive optimization options, it is buggy +! with ALL() and ANY(). We set SYMTOL_DFT to REALMAX to signify this case and disable the check. +! Update 20221229: ifx 2023.0.0 20221201 cannot ensure symmetry even up to 100*EPS if invoked +! with aggressive optimization options and if the floating-point numbers are in single precision. +! Update 20230307: ifx 2023.0.0 20221201 cannot ensure symmetry even up to 10*EPS if invoked with +! -O3 and if the floating-point numbers are in single precision. +! Update 20231002: HUAWEI BiSheng Compiler 2.1.0.B010 (flang) cannot ensure symmetry even up to +! 1.0E2*EPS if invoked with -Ofast and if the floating-point numbers are in single precision. +! This same is observed for arm-linux-compiler-22.1 on Kunpeng. +! Update 20260129: AMD AOMP 22.0 cannot ensure symmetry up to TEN*EPS if invoked with -O3 -fast-math +! and if the floating-point numbers are in single precision. +! +#if (defined __INTEL_COMPILER && PRIMA_REAL_PRECISION < 64 || defined __GFORTRAN__) && PRIMA_AGGRESSIVE_OPTIONS == 1 +! ifx with single precision and aggressive optimization options, or gfortran with aggressive +! optimization options +real(RP), parameter :: SYMTOL_DFT = REALMAX +#elif defined __FLANG && PRIMA_REAL_PRECISION < 64 && PRIMA_AGGRESSIVE_OPTIONS == 1 +! HUAWEI BiSheng Compiler with aggressive optimization options and single precision +real(RP), parameter :: SYMTOL_DFT = max(5.0E3_RP * EPS, TEN**max(-10, -MAXPOW10)) +#elif defined __flang__ && PRIMA_REAL_PRECISION < 64 && PRIMA_AGGRESSIVE_OPTIONS == 1 +! LLVM Flang or ARM ATfL Flang with aggressive optimization options and single precision +real(RP), parameter :: SYMTOL_DFT = max(5.0E3_RP * EPS, TEN**max(-10, -MAXPOW10)) +#elif defined __INTEL_COMPILER && PRIMA_REAL_PRECISION < 64 +! ifx with single precision +real(RP), parameter :: SYMTOL_DFT = max(5.0E1_RP * EPS, TEN**max(-10, -MAXPOW10)) +#elif defined __NAG_COMPILER_BUILD && PRIMA_REAL_PRECISION > 64 +! NAG Fortran Compiler with quadruple precision +real(RP), parameter :: SYMTOL_DFT = max(TEN * EPS, TEN**max(-10, -MAXPOW10)) +#elif PRIMA_RELEASED == 1 && PRIMA_REAL_PRECISION >= 64 +! Double or higher precision in released mode +real(RP), parameter :: SYMTOL_DFT = max(TEN * EPS, TEN**max(-10, -MAXPOW10)) +#elif PRIMA_RELEASED == 1 +! Single or lower precision in released mode +real(RP), parameter :: SYMTOL_DFT = max(1.0E2_RP * EPS, TEN**max(-10, -MAXPOW10)) +#else +! Otherwise +real(RP), parameter :: SYMTOL_DFT = ZERO +#endif + +! ORTHTOL_DFT is the default tolerance for testing orthogonality of matrices. +! In some cases, due to compiler bugs, we need to disable the test. We signify such cases by setting +! ORTHTOL_DFT to REALMAX. For instance, NAG Fortran Compiler is buggy concerning half-precision +! floating-point numbers before Release 7.2 Build 7201. +#if (defined __NAG_COMPILER_BUILD && __NAG_COMPILER_BUILD <= 7200 && PRIMA_REAL_PRECISION <= 16) || (PRIMA_RELEASED == 1) || (PRIMA_DEBUGGING == 0) +real(RP), parameter :: ORTHTOL_DFT = REALMAX +#else +real(RP), parameter :: ORTHTOL_DFT = ZERO +#endif + +! Some default values +! RHOBEG: initial value of the trust region radius. Should be about one tenth of the greatest +! expected change to a variable. +real(RP), parameter :: RHOBEG_DFT = ONE +! RHOEND: final value of the trust region radius. Should indicate the accuracy required in the final +! values of the variables. +real(RP), parameter :: RHOEND_DFT = TEN**max(-6, -MAXPOW10) ! 1.0E-6 +! FTARGET: target value of the objective function. Solvers exit when finding a feasible point with +! the objective function value no more than FTARGET. +real(RP), parameter :: FTARGET_DFT = -REALMAX +! CTOL: tolerance for constraint violation. A point with constraint violation <= CTOL is considered feasible. +real(RP), parameter :: CTOL_DFT = sqrt(EPS) +! CWEIGHT: weight of constraint violation in the merit function used to select the output point. +real(RP), parameter :: CWEIGHT_DFT = TEN**min(8, MAXPOW10) ! 1.0E8 +! ETA1: threshold of reduction ratio for shrinking the trust region radius. +real(RP), parameter :: ETA1_DFT = TENTH +! ETA2: threshold of reduction ratio for expanding the trust region radius. +real(RP), parameter :: ETA2_DFT = 0.7_RP +! GAMMA1: factor for shrinking the trust region radius. +real(RP), parameter :: GAMMA1_DFT = HALF +! GAMMA2: factor for expanding the trust region radius. +real(RP), parameter :: GAMMA2_DFT = TWO +! IPRINT: printing level. 0 means no printing. +integer(IK), parameter :: IPRINT_DFT = 0 +! MAXFUN_DIM_DFT*N is the maximal number of function evaluations. +integer(IK), parameter :: MAXFUN_DIM_DFT = 500 + +! Maximal amount of memory (Byte) allowed for XHIST, FHIST, CONHIST, CHIST, and the filters. +integer, parameter :: MHM = PRIMA_MAX_HIST_MEM_MB * 10**6 +! Make sure that MAXHISTMEM does not exceed HUGE(0) to avoid overflow and memory errors. +integer, parameter :: MAXHISTMEM = min(MHM, (huge(0) - 1) / 2) + +! Maximal length of the filter used in constrained solvers. +integer(IK), parameter :: MIN_MAXFILT = 200 ! Should be positive; < 200 is not recommended. +integer(IK), parameter :: MAXFILT_DFT = 10_IK * MIN_MAXFILT + + +end module consts_mod diff --git a/examples/fortran/prima/native/common/debug.F90 b/examples/fortran/prima/native/common/debug.F90 new file mode 100644 index 000000000..7453f6ccb --- /dev/null +++ b/examples/fortran/prima/native/common/debug.F90 @@ -0,0 +1,174 @@ +#include "ppf.h" + +module debug_mod +!--------------------------------------------------------------------------------------------------! +! This is a module defining some procedures concerning debugging, errors, and warnings. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020. +! +! Last Modified: Tue 09 Sep 2025 11:53:28 PM CST +!--------------------------------------------------------------------------------------------------! +implicit none +private +public :: assert, validate, wassert, backtr, warning, errstop + + +contains + + +subroutine assert(condition, description, srname) +!--------------------------------------------------------------------------------------------------! +! This subroutine checks whether ASSERTION is true. +! If no but DEBUGGING is true, print the following message to STDERR and then stop the program: +! 'ERROR: ' // SRNAME // 'Assertion fails: ' // DESCRIPTION +! MATLAB analogue: assert(condition, sprintf('%s: Assertion fails: %s', srname, description)) +! Python analogue: assert condition, srname + ': Assertion fails: ' + description +! C analogue: assert(condition) /* An error message will be produced by the compiler */ +! N.B.: As in C, we design ASSERT to operate only in the debug mode, i.e., when PRIMA_DEBUGGING == 1; +! when PRIMA_DEBUGGING == 0, ASSERT does nothing. For the checking that should take effect in both +! the debug and release modes, use VALIDATE (see below) instead. In the optimized mode of Python +! (python -O), the Python `assert` will also be ignored. MATLAB does not behave in this way. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : DEBUGGING +use, non_intrinsic :: infos_mod, only : ASSERTION_FAILS +implicit none +logical, intent(in) :: condition ! A condition that is expected to be true +character(len=*), intent(in) :: description ! Description of the condition in human language +character(len=*), intent(in) :: srname ! Name of the subroutine that calls this procedure +if (DEBUGGING .and. .not. condition) then + call errstop(trim(adjustl(srname)), 'Assertion fails: '//trim(adjustl(description)), ASSERTION_FAILS) +end if +end subroutine assert + + +subroutine validate(condition, description, srname) +!--------------------------------------------------------------------------------------------------! +! This subroutine checks whether CONDITION is true. +! If no, print the following message to STDERR and then stop the program: +! 'ERROR: ' // SRNAME // 'Validation fails: ' // DESCRIPTION +! MATLAB analogue: assert(condition, sprintf('%s: Validation fails: %s', srname, description)) +! In Python or C, VALIDATE can be implemented following the Fortran implementation below. +! N.B.: ASSERT checks the condition only when debugging, but VALIDATE does it always. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: infos_mod, only : VALIDATION_FAILS +implicit none +logical, intent(in) :: condition ! A condition that is expected to be true +character(len=*), intent(in) :: description ! Description of the condition in human language +character(len=*), intent(in) :: srname ! Name of the subroutine that calls this procedure +if (.not. condition) then + call errstop(trim(adjustl(srname)), 'Validation fails: '//trim(adjustl(description)), VALIDATION_FAILS) +end if +end subroutine validate + + +subroutine wassert(condition, description, srname) +!--------------------------------------------------------------------------------------------------! +! This subroutine checks whether CONDITION is true. +! If no but DEBUGGING is true, print the following message to STDERR (but do not stop the program): +! 'Warning: ' // SRNAME // 'Assertion fails: ' // DESCRIPTION +! MATLAB analogue: +! !if ~condition +! ! warning(sprintf('%s: Assertion fails: %s', srname, description)) +! !end +! In Python or C, WASSERT can be implemented following the Fortran implementation below. +! N.B.: When DEBUGGING is true, ASSERT stops the program with an error if the condition is false, +! but WASSERT only raises a warning. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : DEBUGGING +implicit none +logical, intent(in) :: condition ! A condition that is expected to be true +character(len=*), intent(in) :: description ! Description of the condition in human language +character(len=*), intent(in) :: srname ! Name of the subroutine that calls this procedure +if (DEBUGGING .and. .not. condition) then + call backtr() + call warning(trim(adjustl(srname)), 'Assertion fails: '//trim(adjustl(description))) +end if +end subroutine wassert + + +subroutine errstop(srname, msg, code) +!--------------------------------------------------------------------------------------------------! +! This subroutine prints 'ERROR: '//STRIP(SRNAME)//': '//STRIP(MSG)//'.' to STDERR, then stop. +! It also calls BACKTR to print the backtrace. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : STDERR +implicit none +character(len=*), intent(in) :: srname +character(len=*), intent(in) :: msg +integer, intent(in), optional :: code + +! `backtr` prints a backtrace. With gfortran 12, even without calling `backtrace`, a backtrace is +! printed when the program is stopped by an error stop. +call backtr() + +write (STDERR, '(/A/)') 'ERROR: '//trim(adjustl(srname))//': '//trim(adjustl(msg))//'.' +if (present(code)) then + ! N.B.: In Fortran 2008, stop code must be a scalar default character or integer CONSTANT + ! expression, but Fortran 2018 lifts the requirement on constancy. gfortran is strict in this + ! aspect. Consequently, for gfortran, compile with either `-std=f2018` or no `-std` at all. + error stop code +else + error stop +end if +! N.B. +! 1. ERROR STOP means to stop the whole program. +! 2. (Zaikun 20230410): We prefer ERROR STOP to STOP, as the former has been allowed in PURE +! procedures since F2018. Later, when F2018 is better supported, we should take advantage of this +! feature to make our subroutines PURE whenever possible. +end subroutine errstop + + +subroutine backtr() +!--------------------------------------------------------------------------------------------------! +! This subroutine calls a compiler-dependent intrinsic to show a backtrace if we are in the +! debugging mode, i.e., PRIMA_DEBUGGING == 1. +! N.B.: +! 1. The intrinsic is compiler-dependent and does not exist in all compilers. Indeed, it is not +! standard-conforming. Therefore, compilers may warn that a non-standard intrinsic is in use. +! 2. More seriously, if the compiler is instructed to conform to the standards (e.g., gfortran with +! the option -std=f2018) while PRIMA_DEBUGGING is set to 1, then the compilation may FAIL when +! linking, complaining that a subroutine cannot be found (e.g., `backtrace` for gfortran). In that +! case, we must either use the `-fall-intrinsics` option of `gfortran`, or set PRIMA_DEBUGGING to 0 +! in ppf.h. This is also why in this subroutine we do not use the constant DEBUGGING defined in the +! consts_mod module but use the macro PRIMA_DEBUGGING in ppf.h. +! 3. As of gfortran 12.1.0, even without calling `backtrace`, a backtrace is printed when the +! program is stopped by an error stop. Therefore, in `errstop`, we do not call `backtr` if the +! compiler is gfortran. However, we cannot remove `backtrace` in `backtr`, because `backtr` is +! also invoked in `wassert`, where `backtrace` is still needed as error stop is not involved. +!--------------------------------------------------------------------------------------------------! +#if PRIMA_DEBUGGING == 1 + +#if defined __GFORTRAN__ +implicit none +call backtrace ! gfortran: if `-std=f20xy` is imposed, then `-fall-intrinsics` is needed. +#elif defined __INTEL_COMPILER +use, non_intrinsic :: ifcore, only : tracebackqq +implicit none +call tracebackqq(user_exit_code=-1) +! According to +! https://www.intel.com/content/www/us/en/docs/fortran-compiler/developer-guide-reference/2024-1/tracebackqq.html, +! by specifying a user exit code of -1, control returns to the calling program. Specifying a user +! exit code with a positive value requests that specified value be returned to the operating system. +! The default value is 0, which causes the application to abort execution. +#endif + +#endif +end subroutine backtr + + +subroutine warning(srname, msg) +!--------------------------------------------------------------------------------------------------! +! This subroutine prints 'Warning: '//STRIP(SRNAME)//': '//STRIP(MSG)//'.' to STDERR. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : STDERR +implicit none +character(len=*), intent(in) :: srname +character(len=*), intent(in) :: msg + +write (STDERR, '(/A/)') 'Warning: '//trim(adjustl(srname))//': '//trim(adjustl(msg))//'.' +end subroutine warning + + +end module debug_mod diff --git a/examples/fortran/prima/native/common/evaluate.f90 b/examples/fortran/prima/native/common/evaluate.f90 new file mode 100644 index 000000000..0819e1258 --- /dev/null +++ b/examples/fortran/prima/native/common/evaluate.f90 @@ -0,0 +1,214 @@ +module evaluate_mod +!--------------------------------------------------------------------------------------------------! +! This is a module evaluating the objective/constraint function with Nan/Inf handling. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: August 2021 +! +! Last Modified: Monday, September 25, 2023 PM08:52:04 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: moderatex +public :: moderatef +public :: moderatec +public :: evaluate + +interface evaluate + module procedure evaluatef, evaluatefc +end interface evaluate + + +contains + + +function moderatex(x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function moderates a decision variable. It replaces NaN by 0 and Inf/-Inf by REALMAX/-REALMAX. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ZERO, REALMAX +use, non_intrinsic :: infnan_mod, only : is_nan +use, non_intrinsic :: linalg_mod, only : trueloc +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +! Outputs +real(RP) :: y(size(x)) + +y = x +y(trueloc(is_nan(x))) = ZERO +y = max(-REALMAX, min(REALMAX, y)) +end function moderatex + + +pure elemental function moderatef(f) result(y) +!--------------------------------------------------------------------------------------------------! +! This function moderates the function value of a MINIMIZATION problem. It replaces NaN and any +! value above FUNCMAX by FUNCMAX. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, REALMAX, FUNCMAX +use, non_intrinsic :: infnan_mod, only : is_nan +implicit none + +! Inputs +real(RP), intent(in) :: f +! Outputs +real(RP) :: y + +y = f +if (is_nan(y)) then + y = FUNCMAX +end if +y = max(-REALMAX, min(FUNCMAX, y)) +! We may moderate huge negative function values as follows, but we decide not to. +!y = max(-FUNCMAX, min(FUNCMAX, y)) +end function moderatef + + +function moderatec(c) result(y) +!--------------------------------------------------------------------------------------------------! +! This function moderates the constraint value, the constraint demanding this value to be NONNEGATIVE. +! It replaces any value below -CONSTRMAX by -CONSTRMAX, and any NaN or value above CONSTRMAX by +! CONSTRMAX. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, CONSTRMAX +use, non_intrinsic :: infnan_mod, only : is_nan +use, non_intrinsic :: linalg_mod, only : trueloc +implicit none + +! Inputs +real(RP), intent(in) :: c(:) +! Outputs +real(RP) :: y(size(c)) + +y = c +y(trueloc(is_nan(c))) = CONSTRMAX +y = max(-CONSTRMAX, min(CONSTRMAX, y)) +end function moderatec + + +subroutine evaluatef(calfun, x, f) +!--------------------------------------------------------------------------------------------------! +! This function evaluates CALFUN at X, setting F to the objective function value. Nan/Inf are +! handled by a moderated extreme barrier. +!--------------------------------------------------------------------------------------------------! +! Common modules +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +use, non_intrinsic :: pintrf_mod, only : OBJ +implicit none + +! Inputs +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +real(RP), intent(in) :: x(:) + +! Output +real(RP), intent(out) :: f + +! Local variables +character(len=*), parameter :: srname = 'EVALUATEF' + +! Preconditions +if (DEBUGGING) then + ! X should not contain NaN if the initial X does not contain NaN and the subroutines generating + ! trust-region/geometry steps work properly so that they never produce a step containing NaN/Inf. + call assert(.not. any(is_nan(x)), 'X does not contain NaN', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (any(is_nan(x))) then + ! Although this should not happen unless there is a bug, we include this case for robustness. + f = sum(x) ! Set F to NaN +else + call calfun(moderatex(x), f) ! Evaluate F; We moderate X before doing so. + + ! Moderated extreme barrier: replace NaN/huge objective or constraint values with a large but + ! finite value. This is naive. Better approaches surely exist. + f = moderatef(f) +end if + + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + ! With X not containing NaN, and with the moderated extreme barrier, F cannot be NaN/+Inf. + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) +end if + +end subroutine evaluatef + + +subroutine evaluatefc(calcfc, x, f, constr) +!--------------------------------------------------------------------------------------------------! +! This function evaluates CALCFC at X, setting F to the objective function value and CONSTR to the +! constraint value. Nan/Inf are handled by a moderated extreme barrier. +!--------------------------------------------------------------------------------------------------! +! Common modules +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +use, non_intrinsic :: pintrf_mod, only : OBJCON +implicit none + +! Inputs +procedure(OBJCON) :: calcfc ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +real(RP), intent(in) :: x(:) + +! Outputs +real(RP), intent(out) :: f +real(RP), intent(out) :: constr(:) + +! Local variables +character(len=*), parameter :: srname = 'EVALUATEFC' + +! Preconditions +if (DEBUGGING) then + ! X should not contain NaN if the initial X does not contain NaN and the subroutines generating + ! trust-region/geometry steps work properly so that they never produce a step containing NaN/Inf. + call assert(.not. any(is_nan(x)), 'X does not contain NaN', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (any(is_nan(x))) then + ! Although this should not happen unless there is a bug, we include this case for robustness. + ! Set F, CONSTR, and CSTRV to NaN. + f = sum(x) + constr = f +else + call calcfc(moderatex(x), f, constr) ! Evaluate F and CONSTR; We moderate X before doing so. + + ! Moderated extreme barrier: replace NaN/huge objective or constraint values with a large but + ! finite value. This is naive, and better approaches surely exist. + f = moderatef(f) + constr = moderatec(constr) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + ! With X not containing NaN, and with the moderated extreme barrier, F cannot be NaN/+Inf, and + ! CONSTR cannot be NaN/+Inf. + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(.not. any(is_nan(constr) .or. is_posinf(constr)), 'CONSTR does not contain NaN/+Inf', srname) +end if + +end subroutine evaluatefc + + +end module evaluate_mod diff --git a/examples/fortran/prima/native/common/fprint.f90 b/examples/fortran/prima/native/common/fprint.f90 new file mode 100644 index 000000000..9990a3372 --- /dev/null +++ b/examples/fortran/prima/native/common/fprint.f90 @@ -0,0 +1,152 @@ +module fprint_mod +!--------------------------------------------------------------------------------------------------! +! This module provides a subroutine that prints a string to STDOUT, STDERR, or a normal file. +! +! N.B.: When interfacing the code with MATLAB, this module needs to be revised to use the MATLAB +! MEX function mexPrintf instead of WRITE. This is because the Fortran WRITE cannot write to the +! STDOUT when the code is interfaced with MATLAB, since the STDOUT is hijacked by MEX. See +! https://stackoverflow.com/questions/26271154/how-can-i-make-a-mex-function-printf-while-its-running +! https://www.mathworks.com/matlabcentral/answers/132527-in-mex-files-where-does-output-to-stdout-and-stderr-go +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and papers. +! +! Started: July 2020 +! +! Last Modified: Sunday, May 21, 2023 AM01:29:25 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: fprint + + +contains + + +subroutine fprint(string, funit, fname, faction) +use, non_intrinsic :: consts_mod, only : IK, STDIN, STDOUT, STDERR, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert, warning +use, non_intrinsic :: string_mod, only : num2str +implicit none + +! Inputs +character(len=*), intent(in) :: string +integer, intent(in), optional :: funit +character(len=*), intent(in), optional :: fname +character(len=*), intent(in), optional :: faction + +! Local variables +character(len=*), parameter :: newline = new_line('') +character(len=*), parameter :: srname = 'FPRINT' +character(len=:), allocatable :: fname_loc +character(len=:), allocatable :: fstat +character(len=:), allocatable :: position +integer :: funit_loc +integer :: i +integer :: iostat +integer :: j +integer :: slen +logical :: fexist + +! Preconditions +if (DEBUGGING) then + if (present(funit)) then + call assert(funit /= STDIN, 'The file unit is not STDIN', srname) + if (present(fname)) then + call assert(len(fname) == 0 .eqv. (funit == STDOUT .or. funit == STDERR), & + & 'The file name is empty if and only if the file unit is either STDOUT or STDERR', srname) + end if + end if + if (present(faction)) then + call assert(faction == 'write' .or. faction == 'w' .or. faction == 'append' .or. faction == 'a', & + & 'FACTION is either "write (w)" or "append (a)"', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +! Decide the file storage unit. +if (present(funit)) then + funit_loc = funit +else + if (present(fname)) then + funit_loc = -1 ! This value will not be used. + else + funit_loc = STDOUT ! Print the message to the standard out. + end if +end if + +! Decide the file name. +if (present(fname)) then + fname_loc = fname +elseif (funit_loc /= STDOUT .and. funit_loc /= STDERR) then + fname_loc = 'fort.'//num2str(int(funit_loc, IK)) +else + fname_loc = '' +end if + +if (DEBUGGING) then + call assert(len(fname_loc) == 0 .eqv. (funit_loc == STDOUT .or. funit_loc == STDERR), & + & 'The file name is empty if and only if the file unit is either STDOUT or STDERR', srname) +end if + +! Open the file if necessary. +iostat = 0 +if (len(fname_loc) > 0) then + ! Decide the position for OPEN. This is the only place where FACTION is used. + position = 'append' + if (present(faction)) then + select case (faction) + case ('write', 'w') + position = 'rewind' + case ('append', 'a') + position = 'append' + case default + call warning(srname, 'Unknown file action "'//faction//'"') + end select + end if + ! Check whether the file is already existing. + inquire (file=fname_loc, exist=fexist) + fstat = merge(tsource='old', fsource='new', mask=fexist) + ! Open the file. + if (present(funit)) then + open (unit=funit_loc, file=fname_loc, status=fstat, position=position, iostat=iostat, action='write') + else + open (newunit=funit_loc, file=fname_loc, status=fstat, position=position, iostat=iostat, action='write') + end if + if (iostat /= 0) then + call warning(srname, 'Failed to open file '//fname_loc) + return + end if +end if + +! Print the string. +! N.B.: `WRITE (FUNIT_LOC, '(A)') STRING` would do what we want, but it causes "Buffer overflow on +! output" if string is long. This did occur with NAG Fortran Compiler R7.1(Hanzomon) Build 7122. +! To avoid this problem, we print the string line by line, separated by newlines. +i = 1 +j = index(string, newline) ! Index of the first newline in the string. +slen = len(string) +do while (j >= i) ! J < I: No more newline in the string. + write (funit_loc, '(A)') string(i:j - 1) ! Print the string before the current newline. + i = j + 1 ! Index of the character after the current newline. + j = i + index(string(i:slen), newline) - 1 ! Index of the next newline. +end do +if (string(i:slen) /= '') then ! Print the string after the last newline. + write (funit_loc, '(A)') string(i:slen) +end if + +! Close the file if necessary. +if (len(fname_loc) > 0 .and. iostat == 0) then + close (funit_loc) +end if + +!====================! +! Calculation ends ! +!====================! +end subroutine fprint + + +end module fprint_mod diff --git a/examples/fortran/prima/native/common/history.f90 b/examples/fortran/prima/native/common/history.f90 new file mode 100644 index 000000000..c9e3a07c7 --- /dev/null +++ b/examples/fortran/prima/native/common/history.f90 @@ -0,0 +1,458 @@ +module history_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines that handle the X/F/C histories of the solver, taking into +! account that MAXHIST may be smaller than NF. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020 +! +! Last Modified: Thursday, April 04, 2024 PM10:15:40 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: prehist +public :: savehist +public :: rangehist + + +contains + + +subroutine prehist(maxhist, n, output_xhist, xhist, output_fhist, fhist, output_chist, chist, m, output_conhist, conhist) +!--------------------------------------------------------------------------------------------------! +! This subroutine revises MAXHIST according to MAXHISTMEM, and allocates memory for the history. +! In MATLAB/Python/Julia/R implementation, we should simply set MAXHIST = MAXFUN and initialize +! XHIST = NaN(N, MAXFUN), FHIST = NaN(1, MAXFUN), CHIST = NaN(1, MAXFUN), CONHIST = NaN(M, MAXFUN), +! if they are requested; replace MAXFUN with 0 for the history that is not requested. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, MAXHISTMEM, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : int +use, non_intrinsic :: memory_mod, only : safealloc, cstyle_sizeof +implicit none + +! Inputs +integer(IK), intent(in) :: n +integer(IK), intent(in), optional :: m +logical, intent(in) :: output_fhist +logical, intent(in) :: output_xhist +logical, intent(in), optional :: output_chist +logical, intent(in), optional :: output_conhist + +! In-outputs +integer(IK), intent(inout) :: maxhist + +! Outputs +real(RP), intent(out), allocatable :: fhist(:) +real(RP), intent(out), allocatable :: xhist(:, :) +real(RP), intent(out), optional, allocatable :: chist(:) +real(RP), intent(out), optional, allocatable :: conhist(:, :) + +! Local variables +character(len=*), parameter :: srname = 'PREHIST' +integer :: unit_memo ! INTEGER(IK) may overflow if IK corresponds to the 16-bit integer. +integer(IK) :: maxhist_in + +! Preconditions +if (DEBUGGING) then + call assert(maxhist >= 0, 'MAXHIST >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + if (present(m)) then + call assert(m >= 0, 'M >= 0', srname) + end if + call assert(present(output_chist) .eqv. present(chist), & + & 'OUTPUT_CHIST and CHIST are both present or both absent', srname) + call assert((present(m) .eqv. present(conhist)) .and. (present(output_conhist) .eqv. present(conhist)), & + & 'M, OUTPUT_CONHIST, and CONHIST are all present or all absent', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Save the input value of MAXHIST for debugging. +maxhist_in = maxhist + +! Revise MAXHIST according to MAXHISTMEM, i.e., the maximal memory allowed for the history. +! N.B.: The `UNIT_MEMO = INT(*)` below converts integers to the default integer kind, which is the +! kind of UNIT_MEMO. Fortran compilers may complain without the conversion. It is not needed in +! Python/MATLAB/Julia/R. Meanwhile, INT(OUTPUT_*HIST) converts booleans to integers. +unit_memo = int(int(output_xhist) * n + int(output_fhist)) +if (present(output_chist) .and. present(chist)) then + unit_memo = int(unit_memo + int(output_chist)) +end if +if (present(m) .and. present(output_conhist) .and. present(conhist)) then + unit_memo = int(unit_memo + int(output_conhist) * m) +end if +unit_memo = unit_memo * int(cstyle_sizeof(0.0_RP)) ! INT(*) avoids overflow when IK is 16-bit. +if (unit_memo <= 0) then ! No output of history is requested + maxhist = 0 +elseif (maxhist > MAXHISTMEM / unit_memo) then + maxhist = int(MAXHISTMEM / unit_memo, kind(maxhist)) ! Integer division. + ! We cannot simply set MAXHIST = MIN(MAXHIST, MAXHISTMEM/UNIT_MEMO), as they may not have + ! the same kind, and compilers may complain. We may convert them, but overflow may occur. +end if + +call safealloc(xhist, n, maxhist * int(output_xhist)) +call safealloc(fhist, maxhist * int(output_fhist)) +! Even if OUTPUT_CHIST is FALSE, CHIST still needs to be allocated. +if (present(output_chist) .and. present(chist)) then + call safealloc(chist, maxhist * int(output_chist)) +end if +! Even if OUTPUT_CONHIST is FALSE, CONHIST still needs to be allocated. +if (present(m) .and. present(output_conhist) .and. present(conhist)) then + call safealloc(conhist, m, maxhist * int(output_conhist)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(maxhist >= 0 .and. maxhist <= maxhist_in, '0 <= MAXHIST <= MAXHIST_IN', srname) + call assert(int(maxhist, kind(MAXHISTMEM)) * int(unit_memo, kind(MAXHISTMEM)) <= MAXHISTMEM, & + & 'The history will not take more memory than MAXHISTMEM', srname) + call assert(allocated(xhist), 'XHIST is allocated', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxhist * int(output_xhist), & + & 'if XHIST is requested, then SIZE(XHIST) == [N, MAXHIST]; otherwise, SIZE(XHIST) == [N, 0]', srname) + call assert(allocated(fhist), 'FHIST is allocated', srname) + call assert(size(fhist) == maxhist * int(output_fhist), & + & 'if FHIST is requested, then SIZE(FHIST) == MAXHIST; otherwise, SIZE(FHIST) == 0', srname) + if (present(output_chist) .and. present(chist)) then + call assert(allocated(chist), 'CHIST is allocated', srname) + call assert(size(chist) == maxhist * int(output_chist), & + & 'if CHIST is requested, then SIZE(CHIST) == MAXHIST; otherwise, SIZE(CHIST) == 0', srname) + end if + if (present(m) .and. present(output_conhist) .and. present(conhist)) then + call assert(allocated(conhist), 'CONHIST is allocated', srname) + call assert(size(conhist, 1) == m .and. size(conhist, 2) == maxhist * int(output_conhist), & + & 'if CONHIST is requested, then SIZE(CONHIST) == [M, MAXHIST]; otherwise, SIZE(CONHIST) == [M, 0]', srname) + end if +end if +end subroutine prehist + + +subroutine savehist(nf, x, xhist, f, fhist, cstrv, chist, constr, conhist) +!--------------------------------------------------------------------------------------------------! +! This subroutine saves X, F, CSTRV, and CONSTR into XHIST, FHIST, CHIST, and CONHIST respectively. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert, wassert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: string_mod, only : num2str +implicit none + +! Inputs +integer(IK), intent(in) :: nf +real(RP), intent(in) :: f +real(RP), intent(in) :: x(:) +real(RP), intent(in), optional :: constr(:) +real(RP), intent(in), optional :: cstrv + +! In-outputs +real(RP), intent(inout) :: fhist(:) +real(RP), intent(inout) :: xhist(:, :) +real(RP), intent(inout), optional :: chist(:) +real(RP), intent(inout), optional :: conhist(:, :) + +! Local variables +integer(IK) :: i +integer(IK) :: maxchist +integer(IK) :: maxconhist +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: nhist +character(len=*), parameter :: srname = 'SAVEHIST' + +! Sizes +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +if (present(chist) .and. present(cstrv)) then + maxchist = int(size(chist), kind(maxchist)) +else + maxchist = 0 +end if +if (present(conhist) .and. present(constr)) then + maxconhist = int(size(conhist, 2), kind(maxconhist)) +else + maxconhist = 0 +end if +maxhist = max(maxxhist, maxfhist, maxchist, maxconhist) + +! Preconditions +if (DEBUGGING) then ! Called after each function evaluation when debugging; can be expensive. + ! Check the presence of CSTRV, CHIST, CONSTR, CONHIST. + call assert(present(cstrv) .eqv. present(chist), 'CSTRV and CHIST are both present or both absent', srname) + call assert(present(constr) .eqv. present(conhist), 'CONSTR and CONHIST are both present or both absent', srname) + ! Check the size of X. + call assert(size(x) >= 1, 'SIZE(X) >= 1', srname) + ! Check the sizes of XHIST, FHIST, CONHIST, CHIST. + call assert(size(xhist, 1) == size(x) .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == SIZE(X), SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(maxchist * (maxchist - maxhist) == 0, 'SIZE(CHIST) == 0 or MAXHIST', srname) + if (present(constr) .and. present(conhist)) then + call assert(size(conhist, 1) == size(constr) .and. maxconhist * (maxconhist - maxhist) == 0, & + & 'SIZE(CONHIST, 1) == SIZE(CONSTR), SIZE(CONHIST, 2) == 0 or MAXNHIST', srname) + end if + ! Check the values of XHIST, FHIST, CHIST, CONHIST, up to the (NF - 1)th position. + ! As long as this subroutine is called, XHIST contains only finite values. + call assert(all(is_finite(xhist(:, 1:min(nf - 1_IK, maxxhist)))), 'XHIST is finite', srname) + call assert(.not. any(is_nan(fhist(1:min(nf - 1_IK, maxfhist))) .or. & + & is_posinf(fhist(1:min(nf - 1_IK, maxfhist)))), 'FHIST does not contain NaN/+Inf', srname) + if (present(chist)) then + call assert(.not. any(chist(1:min(nf - 1_IK, maxchist)) < 0), 'CHIST does not contain negative values', srname) + !------------------------------------------------------------------------------------------! + ! The following test is not applicable to LINCOA. + ! !call assert(.not. any(is_nan(chist(1:min(nf - 1_IK, maxchist))) .or. & + ! ! & is_posinf(chist(1:min(nf - 1_IK, maxchist)))), 'CHIST does not contain NaN/+Inf', srname) + !------------------------------------------------------------------------------------------! + end if + if (present(conhist)) then + call assert(.not. any(is_nan(conhist(:, 1:min(nf - 1_IK, maxconhist))) .or. & + & is_posinf(conhist(:, 1:min(nf - 1_IK, maxconhist)))), 'CONHIST does not contain NaN/Inf', srname) + end if + ! Check the values of X, F, CSTRV, CONSTR. + ! X does not contain NaN if X0 does not and the trust-region/geometry steps are proper. + call assert(.not. any(is_nan(x)), 'X does not contain NaN', srname) + ! F cannot be NaN/+Inf due to the moderated extreme barrier. + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + if (present(cstrv)) then + call assert(.not. (cstrv < 0), 'CSTRV is not negative', srname) + !------------------------------------------------------------------------------------------! + ! The following test is not applicable to LINCOA. + ! !call assert(.not. (is_nan(cstrv) .or. is_posinf(cstrv)), 'CSTRV is NaN/+Inf', srname) + !------------------------------------------------------------------------------------------! + end if + if (present(constr)) then + ! CONSTR cannot contain NaN/+Inf due to the moderated extreme barrier. + call assert(.not. any(is_nan(constr) .or. is_posinf(constr)), 'CONSTR does not contain NaN/+Inf', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +! Save the history. Note that NF may exceed the maximal amount of history to save. We save X and F +! at the position indexed by MODULO(NF - 1, MAXHIST) + 1. When the solver terminates, the history +! will be reordered so that the information is in the chronological order. Similar for CONSTR, CSTRV. +if (maxxhist > 0) then + ! We could replace MODULO(NF - 1_IK, MAXXHIST) + 1_IK) with MODULO(NF - 1_IK, MAXHIST) + 1_IK) + ! based on the assumption that MAXXHIST == 0 or MAXHIST. For robustness, we do not do that. + xhist(:, modulo(nf - 1_IK, maxxhist) + 1_IK) = x +end if +if (maxfhist > 0) then + fhist(modulo(nf - 1_IK, maxfhist) + 1_IK) = f +end if +if (maxchist > 0) then ! MAXCHIST > 0 implies PRESENT(CHIST) and PRESENT(CSTRV) + chist(modulo(nf - 1_IK, maxchist) + 1_IK) = cstrv +end if +if (maxconhist > 0) then ! MAXCONHIST > 0 implies PRESENT(CONHIST) and PRESENT (CONSTR) + conhist(:, modulo(nf - 1_IK, maxconhist) + 1_IK) = constr +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then ! Called after each function evaluation when debugging; can be expensive. + call assert(size(xhist, 1) == size(x) .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [SIZE(X), MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + if (present(chist)) then + call assert(size(chist) == maxchist, 'SIZE(CHIST) == MAXCHIST', srname) + call assert(.not. any(chist(1:min(nf, maxchist)) < 0), 'CHIST does not contain negative values', srname) + !------------------------------------------------------------------------------------------! + ! The following test is not applicable to LINCOA. + ! !call assert(.not. any(is_nan(chist(1:min(nf, maxchist))) .or. is_posinf(chist(1:min(nf, maxchist)))), & + ! ! & 'CHIST does not contain NaN/+Inf', srname) + !------------------------------------------------------------------------------------------! + end if + if (present(conhist) .and. present(constr)) then + call assert(size(conhist, 1) == size(constr) .and. size(conhist, 2) == maxconhist, & + & 'SIZE(CONHIST) == [SIZE(CONSTR), MAXCONHIST]', srname) + call assert(.not. any(is_nan(conhist(:, 1:min(nf, maxconhist))) .or. & + & is_posinf(conhist(:, 1:min(nf, maxconhist)))), 'CONHIST does not contain NaN/+Inf', srname) + end if + + ! The following code checks that XHIST does not contain a segment that repeats. If such a segment + ! is found, we believe that the solver has encountered an infinite cycle, which would be a bug. + ! N.B.: + ! 1. We check this only if NF > (N+1)*(N+2)/2, when the initialization has surely finished. This + ! is because XHIST may contain repeating segments during the initialization if X0 + RHOBEG = X0, + ! which can happen if all entries of X0 are excessively large compared with RHOBEG. It is + ! possible to revise the initialization subroutine to avoid repetition, but we choose not to, + ! a motivation being to keep the initialization parallelizable. + ! 2. We skip the test if N = 1, as false positive may occur (also possible when N > 1, but rare). + ! 3. For segments of length 1, we check whether it repeats three times. For segments of length + ! i > 1, we check whether it repeats twice. Due to rounding errors, it may happen that the same + ! point is repeated twice, but the solver is not in an infinite cycle, which was observed in an + ! experiment of NEWUOA on 20240404. + nhist = min(nf, maxxhist) + n = int(size(x), kind(n)) + if (n > 1 .and. nf > (n + 1) * (n + 2) / 2) then + if (nhist >= 3) then + call wassert(.not. (all(abs(xhist(:, nhist) - xhist(:, nhist - 1)) <= 0) .and. & + & all(abs(xhist(:, nhist - 1) - xhist(:, nhist - 2)) <= 0)), & + & 'XHIST does not contain a repeating segment of length 1', srname) + end if + do i = 2, min(100_IK, nhist / 2_IK) + call wassert(.not. all(abs(xhist(:, nhist - i + 1:nhist) - xhist(:, nhist - 2 * i + 1:nhist - i)) <= 0), & + & 'XHIST does not contain a repeating segment of length '//num2str(i), srname) + end do + end if +end if + +end subroutine savehist + + +subroutine rangehist(nf, xhist, fhist, chist, conhist) +!--------------------------------------------------------------------------------------------------! +! This subroutine arranges FHIST, XHIST, CHIST, and CONHIST in the chronological order. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_posinf +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +integer(IK), intent(in) :: nf + +! In-outputs +real(RP), intent(inout) :: fhist(:) +real(RP), intent(inout) :: xhist(:, :) +real(RP), intent(inout), optional :: chist(:) +real(RP), intent(inout), optional :: conhist(:, :) + +! Local variables +integer(IK) :: khist +integer(IK) :: maxchist +integer(IK) :: maxconhist +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxxhist +integer(IK) :: m +integer(IK) :: n +character(len=*), parameter :: srname = 'RANGEHIST' + +! Sizes +n = int(size(xhist, 1), kind(n)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +if (present(chist)) then + maxchist = int(size(chist), kind(maxchist)) +else + maxchist = 0 +end if +if (present(conhist)) then + m = int(size(conhist, 1), kind(m)) + maxconhist = int(size(conhist, 2), kind(maxconhist)) +else + m = 0 + maxconhist = 0 +end if +maxhist = max(maxxhist, maxfhist, maxconhist, maxchist) + +! Preconditions +if (DEBUGGING) then + ! Check the sizes of XHIST, FHIST, CHIST, CONHIST. + call assert(n >= 1, 'SIZE(XHIST, 1) >= 1', srname) + call assert(maxxhist * (maxxhist - maxhist) == 0, 'SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(maxchist * (maxchist - maxhist) == 0, 'SIZE(CHIST) == 0 or MAXHIST', srname) + call assert(maxconhist * (maxconhist - maxhist) == 0, 'SIZE(CONHIST, 2) == 0 or MAXHIST', srname) + ! Check the values of XHIST, FHIST, CHIST, CONHIST. + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. & + & is_posinf(fhist(1:min(nf, maxfhist)))), 'FHIST does not contain NaN/+Inf', srname) + if (present(chist)) then + call assert(.not. any(chist(1:min(nf, maxchist)) < 0), 'CHIST does not contain negative values', srname) + !------------------------------------------------------------------------------------------! + ! The following test is not applicable to LINCOA. + ! !call assert(.not. any(is_nan(chist(1:min(nf, maxchist))) .or. is_posinf(chist(1:min(nf, maxchist)))), & + ! ! & 'CHIST does not contain NaN/+Inf', srname) + !------------------------------------------------------------------------------------------! + end if + if (present(conhist)) then + call assert(.not. any(is_nan(conhist(:, 1:min(nf, maxconhist))) .or. & + & is_posinf(conhist(:, 1:min(nf, maxconhist)))), 'CONHIST does not contain NaN/+Inf', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +! The ranging should be done only if 0 < MAXXHIST < NF. Otherwise, it leads to errors/wrong results. +if (maxxhist > 0 .and. maxxhist < nf) then + ! We could replace MODULO(NF - 1_IK, MAXXHIST) + 1_IK) with MODULO(NF - 1_IK, MAXHIST) + 1_IK) + ! based on the assumption that MAXXHIST == 0 or MAXHIST. For robustness, we do not do that. + khist = modulo(nf - 1_IK, maxxhist) + 1_IK + xhist = reshape([xhist(:, khist + 1:maxxhist), xhist(:, 1:khist)], shape(xhist)) + ! N.B.: + ! 1. The result of the array constructor is always a rank-1 array (e.g., vector), no matter what + ! elements are used for the construction. + ! 2. The above combination of SHAPE and RESHAPE fulfills our desire thanks to the COLUMN-MAJOR + ! order of Fortran arrays. + ! 3. In MATLAB, `xhist = [xhist(:, khist + 1:maxxhist), xhist(:, 1:khist)]` does the same thing. +end if +! The ranging should be done only if 0 < MAXFHIST < NF. Otherwise, it leads to errors/wrong results. +if (maxfhist > 0 .and. maxfhist < nf) then + khist = modulo(nf - 1_IK, maxfhist) + 1_IK + fhist = [fhist(khist + 1:maxfhist), fhist(1:khist)] +end if +! The ranging should be done only if 0 < MAXCONHIST < NF. Otherwise, it leads to errors/wrong results. +if (maxconhist > 0 .and. maxconhist < nf) then + khist = modulo(nf - 1_IK, maxconhist) + 1_IK + conhist = reshape([conhist(:, khist + 1:maxconhist), conhist(:, 1:khist)], shape(conhist)) +end if +! The ranging should be done only if 0 < MAXCHIST < NF. Otherwise, it leads to errors/wrong results. +if (maxchist > 0 .and. maxchist < nf) then + khist = modulo(nf - 1_IK, maxchist) + 1_IK + chist = [chist(khist + 1:maxchist), chist(1:khist)] +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + if (present(chist)) then + call assert(size(chist) == maxchist, 'SIZE(CHIST) == MAXCHIST', srname) + call assert(.not. any(chist(1:min(nf, maxchist)) < 0), 'CHIST does not contain negative values', srname) + !------------------------------------------------------------------------------------------! + ! The following test is not applicable to LINCOA. + ! !call assert(.not. any(is_nan(chist(1:min(nf, maxchist))) .or. is_posinf(chist(1:min(nf, maxchist)))), & + ! ! & 'CHIST does not contain NaN/+Inf', srname) + !------------------------------------------------------------------------------------------! + end if + if (present(conhist)) then + call assert(size(conhist, 1) == m .and. size(conhist, 2) == maxconhist, & + & 'SIZE(CONHIST) == [M, MAXCONHIST]', srname) + call assert(.not. any(is_nan(conhist(:, 1:min(nf, maxconhist))) .or. & + & is_posinf(conhist(:, 1:min(nf, maxconhist)))), 'CONHIST does not contain NaN/+Inf', srname) + end if +end if + +end subroutine rangehist + + +end module history_mod diff --git a/examples/fortran/prima/native/common/huge.F90 b/examples/fortran/prima/native/common/huge.F90 new file mode 100644 index 000000000..62389fe0f --- /dev/null +++ b/examples/fortran/prima/native/common/huge.F90 @@ -0,0 +1,80 @@ +#include "ppf.h" + +module huge_mod +!--------------------------------------------------------------------------------------------------! +! This module provides a function that returns HUGE(X). See infnan.f90 for more comments. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020. +! +! Last Modified: Tuesday, February 27, 2024 PM11:02:29 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: huge_value + +interface huge_value + module procedure huge_value_sp, huge_value_dp +end interface huge_value + + +#if PRIMA_HP_AVAILABLE == 1 + +interface huge_value + module procedure huge_value_hp +end interface huge_value + +#endif + + +#if PRIMA_QP_AVAILABLE == 1 + +interface huge_value + module procedure huge_value_qp +end interface huge_value + +#endif + + +contains + + +pure elemental function huge_value_sp(x) result(y) +use, non_intrinsic :: consts_mod, only : SP +implicit none +real(SP), intent(in) :: x +real(SP) :: y +y = huge(x) +end function huge_value_sp + +pure elemental function huge_value_dp(x) result(y) +use, non_intrinsic :: consts_mod, only : DP +implicit none +real(DP), intent(in) :: x +real(DP) :: y +y = huge(x) +end function huge_value_dp + +#if PRIMA_HP_AVAILABLE == 1 +pure elemental function huge_value_hp(x) result(y) +use, non_intrinsic :: consts_mod, only : HP +implicit none +real(HP), intent(in) :: x +real(HP) :: y +y = huge(x) +end function huge_value_hp +#endif + +#if PRIMA_QP_AVAILABLE == 1 +pure elemental function huge_value_qp(x) result(y) +use, non_intrinsic :: consts_mod, only : QP +implicit none +real(QP), intent(in) :: x +real(QP) :: y +y = huge(x) +end function huge_value_qp +#endif + +end module huge_mod diff --git a/examples/fortran/prima/native/common/inf.F90 b/examples/fortran/prima/native/common/inf.F90 new file mode 100644 index 000000000..64e21197c --- /dev/null +++ b/examples/fortran/prima/native/common/inf.F90 @@ -0,0 +1,221 @@ +#include "ppf.h" + +module inf_mod +!--------------------------------------------------------------------------------------------------! +! This module provides functions that check whether a real number X is infinite or finite. +! See infnan.f90 for more comments. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020. +! +! Last Modified: Tuesday, February 27, 2024 PM10:57:47 +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: huge_mod, only : huge_value +implicit none +private +public :: is_finite, is_posinf, is_neginf, is_inf + +interface is_finite + module procedure is_finite_sp, is_finite_dp +end interface is_finite + +interface is_posinf + module procedure is_posinf_sp, is_posinf_dp +end interface is_posinf + +interface is_neginf + module procedure is_neginf_sp, is_neginf_dp +end interface is_neginf + +interface is_inf + module procedure is_inf_sp, is_inf_dp +end interface is_inf + + +#if PRIMA_HP_AVAILABLE == 1 + +interface is_finite + module procedure is_finite_hp +end interface is_finite + +interface is_posinf + module procedure is_posinf_hp +end interface is_posinf + +interface is_neginf + module procedure is_neginf_hp +end interface is_neginf + +interface is_inf + module procedure is_inf_hp +end interface is_inf + +#endif + + +#if PRIMA_QP_AVAILABLE == 1 + +interface is_finite + module procedure is_finite_qp +end interface is_finite + +interface is_posinf + module procedure is_posinf_qp +end interface is_posinf + +interface is_neginf + module procedure is_neginf_qp +end interface is_neginf + +interface is_inf + module procedure is_inf_qp +end interface is_inf + +#endif + + +contains + + +pure elemental function is_finite_sp(x) result(y) +use, non_intrinsic :: consts_mod, only : SP +implicit none +real(SP), intent(in) :: x +logical :: y +y = (x <= huge_value(x) .and. x >= -huge_value(x)) +end function is_finite_sp + +pure elemental function is_finite_dp(x) result(y) +use, non_intrinsic :: consts_mod, only : DP +implicit none +real(DP), intent(in) :: x +logical :: y +y = (x <= huge_value(x) .and. x >= -huge_value(x)) +end function is_finite_dp + +pure elemental function is_posinf_sp(x) result(y) +use, non_intrinsic :: consts_mod, only : SP +implicit none +real(SP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) .and. (x > 0) +end function is_posinf_sp + +pure elemental function is_posinf_dp(x) result(y) +use, non_intrinsic :: consts_mod, only : DP +implicit none +real(DP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) .and. (x > 0) +end function is_posinf_dp + +pure elemental function is_neginf_sp(x) result(y) +use, non_intrinsic :: consts_mod, only : SP +implicit none +real(SP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) .and. (x < 0) +end function is_neginf_sp + +pure elemental function is_neginf_dp(x) result(y) +use, non_intrinsic :: consts_mod, only : DP +implicit none +real(DP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) .and. (x < 0) +end function is_neginf_dp + +pure elemental function is_inf_sp(x) result(y) +use, non_intrinsic :: consts_mod, only : SP +implicit none +real(SP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) +end function is_inf_sp + +pure elemental function is_inf_dp(x) result(y) +use, non_intrinsic :: consts_mod, only : DP +implicit none +real(DP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) +end function is_inf_dp + + +#if PRIMA_HP_AVAILABLE == 1 + +pure elemental function is_finite_hp(x) result(y) +use, non_intrinsic :: consts_mod, only : HP +implicit none +real(HP), intent(in) :: x +logical :: y +y = (x <= huge_value(x) .and. x >= -huge_value(x)) +end function is_finite_hp + +pure elemental function is_posinf_hp(x) result(y) +use, non_intrinsic :: consts_mod, only : HP +implicit none +real(HP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) .and. (x > 0) +end function is_posinf_hp + +pure elemental function is_neginf_hp(x) result(y) +use, non_intrinsic :: consts_mod, only : HP +implicit none +real(HP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) .and. (x < 0) +end function is_neginf_hp + +pure elemental function is_inf_hp(x) result(y) +use, non_intrinsic :: consts_mod, only : HP +implicit none +real(HP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) +end function is_inf_hp + +#endif + + +#if PRIMA_QP_AVAILABLE == 1 + +pure elemental function is_finite_qp(x) result(y) +use, non_intrinsic :: consts_mod, only : QP +implicit none +real(QP), intent(in) :: x +logical :: y +y = (x <= huge_value(x) .and. x >= -huge_value(x)) +end function is_finite_qp + +pure elemental function is_posinf_qp(x) result(y) +use, non_intrinsic :: consts_mod, only : QP +implicit none +real(QP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) .and. (x > 0) +end function is_posinf_qp + +pure elemental function is_neginf_qp(x) result(y) +use, non_intrinsic :: consts_mod, only : QP +implicit none +real(QP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) .and. (x < 0) +end function is_neginf_qp + +pure elemental function is_inf_qp(x) result(y) +use, non_intrinsic :: consts_mod, only : QP +implicit none +real(QP), intent(in) :: x +logical :: y +y = (abs(x) > huge_value(x)) +end function is_inf_qp + +#endif + + +end module inf_mod diff --git a/examples/fortran/prima/native/common/infnan.F90 b/examples/fortran/prima/native/common/infnan.F90 new file mode 100644 index 000000000..6191aeced --- /dev/null +++ b/examples/fortran/prima/native/common/infnan.F90 @@ -0,0 +1,153 @@ +#include "ppf.h" + +module infnan_mod +!--------------------------------------------------------------------------------------------------! +! This module provides functions that check whether a real number X is infinite, NaN, or finite. +! +! N.B.: +! +! 1. We implement all the procedures for single, double, and quadruple precisions (when available). +! When we interface the Fortran code with other languages (e.g., MATLAB), the procedures may be +! invoked in both the Fortran code and the gateway (e.g., MEX gateway), which may use different real +! precisions (e.g., the Fortran code may use single, but the MEX gateway uses double by default). +! +! 2. We decide not to use IEEE_IS_NAN and IEEE_IS_FINITE provided by the intrinsic IEEE_ARITHMETIC +! available since Fortran 2003. The reason is as follows. The Fortran standards require these two +! procedures to return default logical values. However, if the code is compiled by gfortran 9.3.0 +! with the option -fdefault-integer-8 (which is adopted by MEX and cannot be changed easily), then +! the compiler will enforce the default logical value to be 64-bit, but the returned kinds of +! IEEE_IS_NAN and IEEE_IS_FINITE will not be changed accordingly, and they will remain 32-bit if +! that is the default logical kind. Therefore, the returned kinds of IEEE_IS_NAN and IEEE_IS_FINITE +! may actually differ from the default logical kind due to this compiler option and hence violate +! the Fortran standard! This is fatal, because a piece of perfectly standard-compliant code may fail +! to be compiled due to type mismatches. It is similar with ifort 2021.2.0 and nagfor 7.0. See more +! discussions at https://stackoverflow.com/questions/69060408. +! +! 3. The functions aim to work even when compilers are invoked with aggressive optimization flags, +! such as `gfortran -Ofast`. +! +! 4. There are many ways to implement functions like IS_NAN. However, not all of them work with +! aggressive optimization flags. For example, for gfortran 9.3.0, the IEEE_IS_NAN included in +! IEEE_ARITHMETIC does not work with `gfortran -Ofast`. Another example, when X is NaN, (X == X) and +! (X >= X) are evaluated as TRUE by Flang 7.1.0 and nvfortran 21.3-0, even if they are invoked +! without any explicit optimization flag. See the following for discussions +! https://stackoverflow.com/questions/15944614 +! +! 5. The most naive implementation for IS_NAN is (X /= X). However, compilers (e.g., gfortran) may +! complain about inequality comparison between floating-point numbers. In addition, it is likely to +! fail when compilers are invoked with aggressive optimization flags. +! +! 6. The implementation below is totally empirical, in the sense that I have not studied in-depth +! what the aggressive optimization flags really do, but only made some tests and found the +! implementation that worked correctly. The story may change when compilers are changed/updated. +! +! 7. N.B.: Do NOT change the functions without thorough testing. Their implementations are delicate. +! For example, when compilers are invoked with aggressive optimization flags, +! (X <= HUGE(X) .AND. X >= -HUGE(X)) may differ from (ABS(X) <= HUGE(X)) , +! (X > HUGE(X) .OR. X < -HUGE(X)) may differ from (ABS(X) > HUGE(X)) , and +! (ABS(X) > HUGE(X) .AND. X > 0) may differ from (X > HUGE(X)) . +! +! 8. IS_NAN must be implemented in a file separated from IS_INF and IS_FINITE (a separated module is +! not enough). Otherwise, IS_NAN may not work with some compilers invoked with aggressive +! optimization flags e.g., ifx -fast with ifx 2022.1.0 or flang -Ofast with flang 15.0.3. +! Similarly, the intrinsic HUGE must be wrapped by HUGE_VALUE in a file separated from IS_INF and +! IS_FINITE. Otherwise, IS_INF and IS_FINITE do not work with `gfortran-13 -Ofast`. +! +! 9. The implementation of IS_NAN may seem unnecessarily complicated and redundant. However, it is +! the only way that I have found to work with all the compilers that I have tested. +! +! 10. Even though the functions involve invocation of ABS and HUGE, their performance (in terms of +! CPU time) turns out comparable to or even better than the functions in IEEE_ARITHMETIC. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020. +! +! Last Modified: Tuesday, February 27, 2024 PM10:56:47 +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: huge_mod, only : huge_value +use, non_intrinsic :: inf_mod, only : is_finite, is_inf, is_posinf, is_neginf +implicit none +private +public :: is_finite, is_posinf, is_neginf, is_inf, is_nan + +interface is_nan + module procedure is_nan_sp, is_nan_dp +end interface is_nan + + +#if PRIMA_HP_AVAILABLE == 1 + +interface is_nan + module procedure is_nan_hp +end interface is_nan +#endif + +#if PRIMA_QP_AVAILABLE == 1 +interface is_nan + module procedure is_nan_qp +end interface is_nan + +#endif + + +contains + + +pure elemental function is_nan_sp(x) result(y) +use, non_intrinsic :: consts_mod, only : SP +implicit none +real(SP), intent(in) :: x +logical :: y +!y = ((.not. (x <= huge_value(x) .and. x >= -huge_value(x)))) .and. (.not. abs(x) > huge_value(x)) +!y = (.not. is_finite(x) .and. .not. (abs(x) > huge_value(x))) .or. y +y = ((.not. is_finite(x)) .and. (.not. is_inf(x))) +y = ((.not. is_inf(x)) .and. (.not. (x <= huge_value(x) .and. x >= -huge_value(x)))) .or. y +end function is_nan_sp + +pure elemental function is_nan_dp(x) result(y) +use, non_intrinsic :: consts_mod, only : DP +implicit none +real(DP), intent(in) :: x +logical :: y +!y = ((.not. (x <= huge_value(x) .and. x >= -huge_value(x)))) .and. (.not. abs(x) > huge_value(x)) +!y = (.not. is_finite(x) .and. .not. (abs(x) > huge_value(x))) .or. y +y = ((.not. is_finite(x)) .and. (.not. is_inf(x))) +y = ((.not. is_inf(x)) .and. (.not. (x <= huge_value(x) .and. x >= -huge_value(x)))) .or. y +end function is_nan_dp + + +#if PRIMA_HP_AVAILABLE == 1 + +pure elemental function is_nan_hp(x) result(y) +use, non_intrinsic :: consts_mod, only : HP +implicit none +real(HP), intent(in) :: x +logical :: y +!y = ((.not. (x <= huge_value(x) .and. x >= -huge_value(x)))) .and. (.not. abs(x) > huge_value(x)) +!y = (.not. is_finite(x) .and. .not. (abs(x) > huge_value(x))) .or. y +y = ((.not. is_finite(x)) .and. (.not. is_inf(x))) +y = ((.not. is_inf(x)) .and. (.not. (x <= huge_value(x) .and. x >= -huge_value(x)))) .or. y +end function is_nan_hp + +#endif + + +#if PRIMA_QP_AVAILABLE == 1 + +pure elemental function is_nan_qp(x) result(y) +use, non_intrinsic :: consts_mod, only : QP +implicit none +real(QP), intent(in) :: x +logical :: y +!y = ((.not. (x <= huge_value(x) .and. x >= -huge_value(x)))) .and. (.not. abs(x) > huge_value(x)) +!y = (.not. is_finite(x) .and. .not. (abs(x) > huge_value(x))) .or. y +y = ((.not. is_finite(x)) .and. (.not. is_inf(x))) +y = ((.not. is_inf(x)) .and. (.not. (x <= huge_value(x) .and. x >= -huge_value(x)))) .or. y +end function is_nan_qp + +#endif + + +end module infnan_mod diff --git a/examples/fortran/prima/native/common/infos.f90 b/examples/fortran/prima/native/common/infos.f90 new file mode 100644 index 000000000..e474a5b98 --- /dev/null +++ b/examples/fortran/prima/native/common/infos.f90 @@ -0,0 +1,56 @@ +module infos_mod +!--------------------------------------------------------------------------------------------------! +! This is a module defining exit flags. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020. +! +! Last Modified: Sunday, May 21, 2023 PM03:00:41 +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: consts_mod, only : IK + +implicit none +private +public :: INFO_DFT +public :: SMALL_TR_RADIUS +public :: FTARGET_ACHIEVED +public :: TRSUBP_FAILED +public :: MAXFUN_REACHED +public :: MAXTR_REACHED +public :: NAN_INF_X +public :: NAN_INF_F +public :: NAN_INF_MODEL +public :: DAMAGING_ROUNDING +public :: NO_SPACE_BETWEEN_BOUNDS +public :: ZERO_LINEAR_CONSTRAINT +public :: CALLBACK_TERMINATE +public :: INVALID_INPUT +public :: ASSERTION_FAILS +public :: VALIDATION_FAILS +public :: MEMORY_ALLOCATION_FAILS + +integer(IK), parameter :: INFO_DFT = 0 +integer(IK), parameter :: SMALL_TR_RADIUS = 0 +integer(IK), parameter :: FTARGET_ACHIEVED = 1 +integer(IK), parameter :: TRSUBP_FAILED = 2 +integer(IK), parameter :: MAXFUN_REACHED = 3 +integer(IK), parameter :: MAXTR_REACHED = 20 +integer(IK), parameter :: NAN_INF_X = -1 +integer(IK), parameter :: NAN_INF_F = -2 +integer(IK), parameter :: NAN_INF_MODEL = -3 +integer(IK), parameter :: NO_SPACE_BETWEEN_BOUNDS = 6 +integer(IK), parameter :: DAMAGING_ROUNDING = 7 +integer(IK), parameter :: ZERO_LINEAR_CONSTRAINT = 8 +integer(IK), parameter :: CALLBACK_TERMINATE = 30 + +! Stop-codes. +! The following codes are used by ERROR STOP as stop-codes, which should be default integers. +integer, parameter :: INVALID_INPUT = 100 +integer, parameter :: ASSERTION_FAILS = 101 +integer, parameter :: VALIDATION_FAILS = 102 +integer, parameter :: MEMORY_ALLOCATION_FAILS = 103 + + +end module infos_mod diff --git a/examples/fortran/prima/native/common/linalg.f90 b/examples/fortran/prima/native/common/linalg.f90 new file mode 100644 index 000000000..b77db15f5 --- /dev/null +++ b/examples/fortran/prima/native/common/linalg.f90 @@ -0,0 +1,3105 @@ +module linalg_mod +!--------------------------------------------------------------------------------------------------! +! This module provides some basic linear algebra procedures. +! +! The procedures are NOT intended to be optimized but to be sufficient for my projects. The projects +! are mainly the development and maintenance of derivative-free optimization software, where the +! major expense comes from the function evaluations, NOT the numerical linear algebraic computations, +! and the sizes of matrices/vectors involved are relatively SMALL, the order being at most 10^3. +! +! If your needs are of a different nature, you may still use these procedures to prototype your +! ideas, but keep in mind that the implementations here are mostly STRAIGHTFORWARD and NAIVE, and +! some algorithms selected here may be suboptimal for your problems. +! +! If it is needed to enhance the performance of these procedures, one can optimize their +! implementations according to the resources (hardware, e.g., C/GPU, cache, and libraries, e.g., +! BLAS, LAPACK) available and the sizes of the matrices/vectors concerned. +! +! In case you need similar procedures in MATLAB/Python/Julia/R, note the following. +! 1. Most of the procedures here are intrinsic to the languages or available in standard libraries. +! If available, they should NOT be implemented from scratch like we do here. +! 2. For the procedures that are not available, it may be better to code them inline instead of as +! external functions, because the code is usually short using matrix/vector operations, and because +! the overhead of function calling can be high in these languages. +! 3. In Fortran, we implement the procedures as subroutines/functions here for several reasons. +! 3.1.) Most of the procedures are not intrinsically available in Fortran. +! 3.2.) When using these procedures for the modernization of Powell's derivative-free software, we +! want to start with an implementation that is verifiably faithful to Powell's original code. To +! achieve such faithfulness, it is not always possible to use the intrinsic matrix/vector procedures +! in Fortran, the most noticeable examples being DOT_PRODUCT (v.s. INPROD) and MATMUL (v.s. MATPROD). +! Powell implemented all matrix/vector operations by loops, which may not be the case for intrinsic +! procedures such as MATMUL and DOT_PRODUCT. Different implementations lead to slightly different +! results due to rounding, and hence the verification of faithfulness will fail. +! 3.3.) As of 20220507, with some compilers, the performance of Fortran's intrinsic matrix/vector +! procedures may not be as good as naive loops, let alone highly optimized libraries like BLAS. +! Concentrating all the linear algebra procedures at one place as we do here, it will be relatively +! easy to optimize them when necessary. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020 +! +! Last Modified: Fri 13 Feb 2026 05:11:41 PM CET +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: inprod, matprod, outprod ! Mathematically, INPROD = DOT_PRODUCT, MATPROD = MATMUL +public :: r1update, r2update, symmetrize +public :: eye +public :: diag +public :: hypotenuse, planerot +public :: project +public :: inv, isinv +public :: solve +public :: lsqr +public :: isminor +public :: issymmetric, isorth, istriu +public :: sort +public :: trueloc, falseloc +public :: minimum, maximum +public :: norm +public :: linspace +public :: hessenberg +public :: eigmin +public :: vec2smat, smat2vec, smat_mul_vec +public :: int + +interface matprod + module procedure matprod12, matprod21, matprod22 +! N.B.: +! 1.matprod22(x, y) may differ from the intrinsic matmul(x, y) in finite-precision arithmetic. This +! means that the implementation of matmul is not a naive triple loop. The difference has been +! observed on matprod22 and matprod12. The second case occurred on Oct. 11, 2021 in the +! trust-region subproblem solver of COBYLA, and it took enormous time to find out that Powell's +! code and the modernized code behaved differently due to matmul and matprod12 when calculating +! RESMAX (in Powell's code) and CSTRV (in the modernized code) when stage 2 starts. +! 2. When interfaced with MATLAB, the intrinsic matmul and dot_product seem not as efficient as the +! implementations below (mostly by loops). This may depend on the machine (e.g., cache size), +! compiler, compiling options, and MATLAB version. +end interface matprod + +interface r1update + module procedure r1_sym, r1 +end interface r1update + +interface r2update + module procedure r2_sym, r2 +end interface r2update + +interface eye + module procedure eye1, eye2 +end interface eye + +interface project + module procedure project1, project2 +end interface + +interface lsqr + module procedure lsqr_Rdiag, lsqr_Rfull +end interface + +interface isminor + module procedure isminor0, isminor1 +end interface isminor + +interface sort + module procedure sort_i1, sort_i2 +end interface sort + +interface minimum + module procedure minimum1, minimum2 +end interface minimum + +interface maximum + module procedure maximum1, maximum2 +end interface maximum + +interface norm + module procedure p_norm, named_norm_vec, named_norm_mat +end interface norm + +interface linspace + module procedure linspace_r, linspace_i +end interface linspace + +interface hessenberg + module procedure hessenberg_hhd_trid, hessenberg_full +end interface hessenberg + +interface eigmin + module procedure eigmin_sym_trid +end interface + +interface int + module procedure logical_to_int +end interface int + + +contains + + +subroutine r1_sym(A, alpha, x) +!--------------------------------------------------------------------------------------------------! +! R1_SYM sets +! A = A + ALPHA*( X*X^T ), +! where A is an NxN matrix, ALPHA is a scalar, and X is an N-dimensional vector. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: alpha +real(RP), intent(in) :: x(:) +! In-outputs +real(RP), intent(inout) :: A(:, :) ! A(SIZE(X), SIZE(X)) +! Local variables +character(len=*), parameter :: srname = 'R1_SYM' +integer(IK) :: n, j + +! Sizes +n = int(size(x), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(A, 1) == n .and. size(A, 2) == n, 'SIZE(A) == [N, N]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Only update the LOWER TRIANGULAR part of A. +do j = 1, n + A(j:n, j) = A(j:n, j) + alpha * x(j:n) * x(j) +end do +call symmetrize(A) ! Copy A(LOWER_TRI) to A(UPPER_TRI). + +! For some reason, A + alpha*outprod(x,x), A + (outprod(alpha*x, x) + outprod(x, alpha*x))/2, +! A + symmetrize(x, alpha*x), or A + sign(alpha) * outprod(sqrt(|alpha|) * x, sqrt(|alpha|) * x) +! does not work as well as the above lines in NEWUOA, where SYMMETRIZE should copy A(LOWER_TRI) +! to A(UPPER_TRI) rather than set A = (A'+A)/2. When X is rather small or large, calculating +! OUTPROD(X, X) can be a bad idea, even though it guarantees symmetry in finite-precision arithmetic. + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(A, 1) == n .and. issymmetric(A), 'A is N-by-N and symmetric', srname) +end if +end subroutine r1_sym + + +subroutine r1(A, alpha, x, y) +!--------------------------------------------------------------------------------------------------! +! R1 sets +! A = A + ALPHA*( X*Y^T ), +! where A is an MxN matrix, ALPHA is a real scalar, X is an M-dimensional vector, and Y is an +! N-dimensional vector. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: alpha +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: y(:) +! In-outputs +real(RP), intent(inout) :: A(:, :) ! A(SIZE(X), SIZE(Y)) +! Local variables +character(len=*), parameter :: srname = 'R1' + +! Preconditions +if (DEBUGGING) then + call assert(size(A, 1) == size(x) .and. size(A, 2) == size(y), 'SIZE(A) == [SIZE(X), SIZE(Y)]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! N.B.: The use of OUTPROD is expensive memory-wise, but it is not our concern in this implementation. +A = A + outprod(alpha * x, y) +!A = A + alpha * outprod(x, y) + +!====================! +! Calculation ends ! +!====================! +end subroutine r1 + + +subroutine r2_sym(A, alpha, x, y) +!--------------------------------------------------------------------------------------------------! +! R2_SYM sets +! A = A + ALPHA*( X*Y^T + Y*X^T ), +! where A is an NxN matrix, X and Y are N-dimensional vectors, and alpha is a scalar. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: alpha +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: y(:) +! In-outputs +real(RP), intent(inout) :: A(:, :) ! A(SIZE(X), SIZE(X)) +! Local variables +character(len=*), parameter :: srname = 'R2_SYM' +integer(IK) :: n, j + +! Sizes +n = int(size(x), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(y) == n, 'SIZE(Y) == N', srname) + call assert(size(A, 1) == n .and. size(A, 2) == n, 'SIZE(A) == [N, N]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +do j = 1, n + A(j:n, j) = A(j:n, j) + alpha * x(j:n) * y(j) + alpha * y(j:n) * x(j) +end do +call symmetrize(A) ! Copy A(LOWER_TRI) to A(UPPER_TRI). + +! For some reason, A = A + ALPHA * (OUTPROD(X, Y) + OUTPROD(Y, X)) does not work as well as the +! above lines for NEWUOA, where SYMMETRIZE should copy A(LOWER_TRI) to A(UPPER_TRI), although +! ALPHA*( X*Y^T + Y*X^T) is guaranteed symmetric even in floating-point arithmetic. + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(issymmetric(A), 'A is symmetric', srname) +end if +end subroutine r2_sym + + +subroutine r2(A, alpha, x, y, beta, u, v) +!--------------------------------------------------------------------------------------------------! +! R2 sets +! A = A + ( ALPHA*( X*Y^T ) + BETA*( U*V^T ) ), +! where A is an MxN matrix, ALPHA and BETA are real scalars, X and U are M-dimensional vectors, +! Y and V are N-dimensional vectors. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: alpha +real(RP), intent(in) :: beta +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: y(:) +real(RP), intent(in) :: u(:) ! U(SIZE(X)) +real(RP), intent(in) :: v(:) ! V(SIZE(Y)) +! In-outputs +real(RP), intent(inout) :: A(:, :) ! A(SIZE(X), SIZE(Y)) +! Local variables +character(len=*), parameter :: srname = 'R2' + +! Preconditions +if (DEBUGGING) then + call assert(size(u) == size(x), 'SIZE(U) == SIZE(X)', srname) + call assert(size(v) == size(y), 'SIZE(V) == SIZE(Y)', srname) + call assert(size(A, 1) == size(x) .and. size(A, 2) == size(y), 'SIZE(A) == [SIZE(X), SIZE(Y)]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! N.B.: The use of OUTPROD is expensive memory-wise, but it is not our concern in this implementation. +A = A + outprod(alpha * x, y) + outprod(beta * u, v) +!A = A + (alpha * outprod(x, y) + beta * outprod(u, v)) + +!====================! +! Calculation ends ! +!====================! +end subroutine r2 + + +function matprod12(x, y) result(z) +!--------------------------------------------------------------------------------------------------! +! This procedure calculates the matrix product of X and Y, where X is an M-dimensional vector +! considered as a row, and Y is an M-by-N matrix. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: y(:, :) +! Outputs +real(RP) :: z(size(y, 2)) +! Local variables +character(len=*), parameter :: srname = 'MATPROD12' +integer(IK) :: j + +! Preconditions +if (DEBUGGING) then + call assert(size(x) == size(y, 1), 'SIZE(X) == SIZE(Y, 1)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +do j = 1, int(size(y, 2), kind(j)) + ! When interfaced with MATLAB, the following seems more efficient than a loop, which is strange + ! since inprod itself is implemented by a loop. This may depend on the machine (e.g., cache + ! size), compiler, compiling options, and MATLAB version. + z(j) = inprod(x, y(:, j)) +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(z) == size(y, 2), 'SIZE(Z) == SIZE(Y, 2)', srname) +end if +end function matprod12 + + +function matprod21(x, y) result(z) +!--------------------------------------------------------------------------------------------------! +! This procedure calculates the matrix product of X and Y, where X is an M-by-N matrix, and Y is an +! M-dimensional vector considered as a column. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: x(:, :) +real(RP), intent(in) :: y(:) +! Outputs +real(RP) :: z(size(x, 1)) +! Local variables +character(len=*), parameter :: srname = 'MATPROD21' +integer(IK) :: j + +! Preconditions +if (DEBUGGING) then + call assert(size(x, 2) == size(y), 'SIZE(X, 2) == SIZE(Y)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +z = ZERO +do j = 1, int(size(x, 2), kind(j)) + z = z + x(:, j) * y(j) +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(z) == size(x, 1), 'SIZE(Z) == SIZE(X, 1)', srname) +end if +end function matprod21 + + +function matprod22(x, y) result(z) +!--------------------------------------------------------------------------------------------------! +! This procedure calculates the matrix product of X and Y, where X is an M-by-P matrix, and Y is a +! P-by-N matrix. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: x(:, :) +real(RP), intent(in) :: y(:, :) +! Outputs +real(RP) :: z(size(x, 1), size(y, 2)) +! Local variables +character(len=*), parameter :: srname = 'MATPROD22' +integer(IK) :: i, j + +! Preconditions +if (DEBUGGING) then + call assert(size(x, 2) == size(y, 1), 'SIZE(X, 2) == SIZE(Y, 1)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +z = ZERO +do j = 1, int(size(y, 2), kind(j)) + do i = 1, int(size(x, 2), kind(i)) + z(:, j) = z(:, j) + x(:, i) * y(i, j) + end do +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(z, 1) == size(x, 1) .and. size(z, 2) == size(y, 2), '[SIZE(Z) == SIZE(X, 1), SIZE(Y, 2)]', srname) +end if +end function matprod22 + + +function inprod(x, y) result(z) +!--------------------------------------------------------------------------------------------------! +! INPROD calculates the inner product of X and Y, i.e., Z = X^T*Y, regarding X and Y as columns. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: y(:) +! Outputs +real(RP) :: z +! Local variables +character(len=*), parameter :: srname = 'INPROD' +integer(IK) :: i + +! Preconditions +if (DEBUGGING) then + call assert(size(x) == size(y), 'SIZE(X) == SIZE(Y)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +z = ZERO +do i = 1, int(size(x), kind(i)) + z = z + x(i) * y(i) +end do + +!====================! +! Calculation ends ! +!====================! +end function inprod + + +function outprod(x, y) result(z) +!--------------------------------------------------------------------------------------------------! +! OUTPROD calculates the outer product of X and Y, i.e., Z = X*Y^T, regarding X and Y as columns. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: y(:) +! Outputs +real(RP) :: z(size(x), size(y)) +! Local variables +character(len=*), parameter :: srname = 'OUTPROD' +integer(IK) :: i + +!====================! +! Calculation starts ! +!====================! + +do i = 1, int(size(y), kind(i)) + z(:, i) = x * y(i) +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(z, 1) == size(x) .and. size(z, 2) == size(y), 'SIZE(Z) == [SIZE(X), SIZE(Y)]', srname) +end if +end function outprod + + +function eye1(n) result(x) +!--------------------------------------------------------------------------------------------------! +! EYE1 is the univariate case of EYE, a function similar to the MATLAB function with the same name. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +integer(IK), intent(in) :: n +! Outputs +real(RP) :: x(max(n, 0_IK), max(n, 0_IK)) +! Local variables +character(len=*), parameter :: srname = 'EYE1' +integer(IK) :: i + +!====================! +! Calculation starts ! +!====================! + +if (size(x, 1) * size(x, 2) > 0) then + x = ZERO + do i = 1, int(min(size(x, 1), size(x, 2)), kind(i)) + x(i, i) = ONE + end do +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(x, 1) == max(n, 0_IK) .and. size(x, 2) == max(n, 0_IK), 'SIZE(X) == [N, N]', srname) +end if +end function eye1 + + +function eye2(m, n) result(x) +!--------------------------------------------------------------------------------------------------! +! EYE2 is the bivariate case of EYE, a function similar to the MATLAB function with the same name. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +integer(IK), intent(in) :: m +integer(IK), intent(in) :: n +! Outputs +real(RP) :: x(max(m, 0_IK), max(n, 0_IK)) +! Local variables +character(len=*), parameter :: srname = 'EYE2' +integer(IK) :: i + +!====================! +! Calculation starts ! +!====================! + +if (size(x, 1) * size(x, 2) > 0) then + x = ZERO + do i = 1, int(min(size(x, 1), size(x, 2)), kind(i)) + x(i, i) = ONE + end do +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(x, 1) == max(m, 0_IK) .and. size(x, 2) == max(n, 0_IK), 'SIZE(X) == [M, N]', srname) +end if +end function eye2 + + +function solve(A, b) result(x) +!--------------------------------------------------------------------------------------------------! +! This function solves the linear system A*X = B. We assume that A is a square matrix that is small +! and invertible, and B is a vector of length SIZE(A, 1). The implementation is NAIVE. +! TODO: Better to implement it into several subfunctions: triu, tril, and general square. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +real(RP), intent(in) :: b(:) +! Outputs +real(RP) :: x(size(A, 2)) +! Local variables +character(len=*), parameter :: srname = 'SOLVE' +integer(IK) :: P(size(A, 1)) +integer(IK) :: i +integer(IK) :: n +real(RP) :: Q(size(A, 1), size(A, 1)) +real(RP) :: R(size(A, 1), size(A, 2)) +real(RP) :: tol + +! Sizes +n = int(size(A, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(A, 1) == size(A, 2), 'A is square', srname) + call assert(size(b) == size(A, 1), 'SIZE(B) == SIZE(A, 1)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (n <= 0) then ! Of course, N < 0 should never happen. + return +end if + +! Zaikun 20220527: With the following code, Huawei Bisheng flang 2.1.0, Arm Fortran Compiler 23.1, +! and AOCC 5.1 flang, which raise a false positive error about out-bound subscripts when invoked +! with the -Mbounds flag. See https://github.com/flang-compiler/flang/issues/1238 +if (istril(A)) then + do i = 1, n + x(i) = (b(i) - inprod(A(i, 1:i - 1), x(1:i - 1))) / A(i, i) ! INPROD = 0 if I == 1. + end do +elseif (istriu(A)) then ! This case is invoked in LINCOA. + do i = n, 1, -1 + x(i) = (b(i) - inprod(A(i, i + 1:n), x(i + 1:n))) / A(i, i) ! INPROD = 0 if I == N. + end do +else + ! This is NOT a good algorithm for linear systems, but since the QR subroutine is available ... + call qr(A, Q, R, P) + x = matprod(b, Q) + do i = n, 1, -1 + x(i) = (x(i) - inprod(R(i, i + 1:n), x(i + 1:n))) / R(i, i) ! INPROD = 0 if I == N. + end do + x(P) = x ! Handle the permutation. +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(x) == size(A, 2), 'SIZE(X) == SIZE(A, 2)', srname) + if (is_finite(sum(abs(A)) + sum(abs(b)))) then + tol = max(TEN**max(-8, -MAXPOW10), min(1.0E-1_RP, TEN**min(8, MAXPOW10) * EPS * real(n + 1_IK, RP))) + call assert(norm(matprod(A, x) - b) <= tol * maxval([ONE, norm(b), norm(x)]), 'A*X == B', srname) + end if +end if +end function solve + + +function inv(A) result(B) +!--------------------------------------------------------------------------------------------------! +! This function calculates the inverse of a matrix A, which is ASSUMED TO BE SMALL AND INVERTIBLE. +! The function is implemented NAIVELY. It is NOT coded for general purposes but only for the usage +! in this project. Indeed, only the lower triangular case is used. +! TODO: extend this function to calculate the pseudo inverse of any matrix of full rank. Better to +! implement it into several subfunctions: triu with M >= N, tril with M <= N; general with M >= N, +! general with M <= N, etc. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TEN, MAXPOW10, EPS, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +! Outputs +real(RP) :: B(size(A, 1), size(A, 1)) +! Local variables +character(len=*), parameter :: srname = 'INV' +integer(IK) :: P(size(A, 1)) +integer(IK) :: InvP(size(A, 1)) +integer(IK) :: i +integer(IK) :: n +real(RP) :: Q(size(A, 1), size(A, 1)) +real(RP) :: R(size(A, 1), size(A, 1)) +real(RP) :: tol + +! Sizes +n = int(size(A, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(A, 1) == size(A, 2), 'A is square', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (n <= 0) then ! Of course, N < 0 should never happen. + return +end if + +if (istril(A)) then + ! This case is invoked in COBYLA. + R = transpose(A) ! Take transpose to work on columns. + B = ZERO + do i = 1, n + B(i, i) = ONE / R(i, i) + B(1:i - 1, i) = -matprod(B(1:i - 1, 1:i - 1), R(1:i - 1, i) / R(i, i)) + end do + B = transpose(B) +elseif (istriu(A)) then + B = ZERO + do i = 1, n + B(i, i) = ONE / A(i, i) + B(1:i - 1, i) = -matprod(B(1:i - 1, 1:i - 1), A(1:i - 1, i) / A(i, i)) + end do +else + ! This is NOT the best algorithm for the inverse, but since the QR subroutine is available ... + call qr(A, Q, R, P) + R = transpose(R) ! Take transpose to work on columns. + B = ZERO + do i = n, 1, -1 + B(:, i) = (Q(:, i) - matprod(B(:, i + 1:n), R(i + 1:n, i))) / R(i, i) + end do + InvP(P) = linspace(1_IK, n, n) ! The inverse permutation + B = transpose(B(:, InvP)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(B, 1) == n .and. size(B, 2) == n, 'SIZE(B) == [N, N]', srname) + call assert(istril(B) .or. .not. istril(A), 'If A is lower triangular, then so is B', srname) + call assert(istriu(B) .or. .not. istriu(A), 'If A is upper triangular, then so is B', srname) + tol = max(TEN**max(-8, -MAXPOW10), min(1.0E-1_RP, TEN**min(10, MAXPOW10) * EPS * real(n + 1_IK, RP))) + call assert(isinv(A, B, tol), 'B = A^{-1}', srname) +end if +end function inv + + +function isinv(A, B, tol) result(is_inv) +!--------------------------------------------------------------------------------------------------! +! This procedure tests whether A = B^{-1} up to the tolerance TOL. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, EPS, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +real(RP), intent(in) :: B(:, :) +real(RP), intent(in), optional :: tol +! Outputs +logical :: is_inv +! Local variables +character(len=*), parameter :: srname = 'ISINV' +real(RP) :: tol_loc +integer(IK) :: n + +! Sizes +n = int(size(A, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(A, 1) == size(A, 2), 'A is square', srname) + call assert(size(B, 1) == size(B, 2), 'B is square', srname) + call assert(size(A, 1) == size(B, 1), 'SIZE(A) == SIZE(B)', srname) + if (present(tol)) then + call assert(tol >= 0, 'TOL >= 0', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +if (present(tol)) then + tol_loc = tol +else + tol_loc = min(1.0E-3_RP, 1.0E2_RP * EPS * real(max(size(A, 1), size(A, 2)), RP)) +end if +tol_loc = maxval([tol_loc, tol_loc * maxval(abs(A)), tol_loc * maxval(abs(B))]) +is_inv = all(abs(matprod(A, B) - eye(n)) <= tol_loc) .or. all(abs(matprod(B, A) - eye(n)) <= tol_loc) + +!====================! +! Calculation ends ! +!====================! +end function isinv + + +subroutine qr(A, Q, R, P) +!--------------------------------------------------------------------------------------------------! +! This subroutine calculates the QR factorization of A, possibly with column pivoting, so that +! A = Q*R (if no pivoting) or A(:, P) = Q*R (if pivoting), where the columns of Q are orthonormal, +! and R is upper triangular. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +! Outputs +real(RP), intent(out), optional :: Q(:, :) +real(RP), intent(out), optional :: R(:, :) +integer(IK), intent(out), optional :: P(:) +! Local variables +character(len=*), parameter :: srname = 'QR' +logical :: pivot +integer(IK) :: i +integer(IK) :: j +integer(IK) :: k +integer(IK) :: m +integer(IK) :: n +real(RP) :: G(2, 2) +real(RP) :: Q_loc(size(A, 1), size(A, 1)) +real(RP) :: T(size(A, 2), size(A, 1)) +real(RP) :: tol + +if (.not. (present(Q) .or. present(R) .or. present(R))) then + return +end if + +! Sizes +m = int(size(A, 1), kind(m)) +n = int(size(A, 2), kind(n)) + +! Preconditions +if (DEBUGGING) then + if (present(Q)) then + call assert(size(Q, 1) == m .and. (size(Q, 2) == m .or. size(Q, 2) == min(m, n)), & + & 'SIZE(Q) == [M, N] .or. SIZE(Q) == [M, MIN(M, N)]', srname) + end if + if (present(R)) then + call assert((size(R, 1) == m .or. size(R, 1) == min(m, n)) .and. size(R, 2) == n, & + & 'SIZE(R) == [M, N] .or. SIZE(R) == [MIN(M, N), N]', srname) + end if + if (present(Q) .and. present(R)) then + call assert(size(Q, 2) == size(R, 1), 'SIZE(Q, 2) == SIZE(R, 1)', srname) + end if + if (present(P)) then + call assert(size(P) == n, 'SIZE(P) == N', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +pivot = (present(P)) +Q_loc = eye(m) +T = transpose(A) ! T is the transpose of R. We consider T in order to work on columns. +if (pivot) then + P = linspace(1_IK, n, n) +end if + +do j = 1, n + if (pivot) then + k = int(maxloc(sum(T(j:n, j:m)**2, dim=2), dim=1), kind(k)) + if (k > 1 .and. k <= n - j + 1) then + k = k + j - 1_IK + P([j, k]) = P([k, j]) + T([j, k], :) = T([k, j], :) + end if + end if + do i = m, j + 1_IK, -1_IK + G = transpose(planerot(T(j, [j, i]))) + T(j, [j, i]) = [hypotenuse(T(j, j), T(j, i)), ZERO] !T(j, [j, i]) = [sqrt(T(j, j)**2 + T(j, i)**2), ZERO] + T(j + 1:n, [j, i]) = matprod(T(j + 1:n, [j, i]), G) + Q_loc(:, [j, i]) = matprod(Q_loc(:, [j, i]), G) + end do +end do + +if (present(Q)) then + Q = Q_loc(:, 1:size(Q, 2)) +end if +if (present(R)) then + R = transpose(T(:, 1:size(R, 1))) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(4, MAXPOW10) * EPS * real(max(m, n) + 1_IK, RP))) + call assert(isorth(Q_loc, tol), 'The columns of Q are orthonormal', srname) + call assert(istril(T, tol), 'R is upper triangular', srname) + if (pivot) then + call assert(all(abs(matprod(Q_loc, transpose(T)) - A(:, P)) <= & + max(tol, tol * maxval(abs(A)))), 'A(:, P) == Q*R', srname) + do j = 1, min(m, n) - 1_IK + ! The following test cannot be passed on ill-conditioned problems. + !call assert(abs(T(j, j)) + max(tol, tol * abs(T(j, j))) >= & + ! & abs(T(j + 1, j + 1)), '|R(J, J)| >= |R(J + 1, J + 1)|', srname) + call assert(all(T(j, j)**2 + max(tol, tol * T(j, j)**2) >= & + & sum(T(j + 1:n, j:min(m, n))**2, dim=2)), & + & 'R(J, J)^2 >= SUM(R(J : MIN(M, N), J + 1 : N).^2', srname) + end do + else + call assert(all(abs(matprod(Q_loc, transpose(T)) - A) <= max(tol, tol * maxval(abs(A)))), & + & 'A == Q*R', srname) + end if +end if +end subroutine qr + + +function lsqr_Rdiag(A, b, Q, Rdiag) result(x) +!--------------------------------------------------------------------------------------------------! +! This function solves the linear least squares problem min ||A*x - b||_2 by the QR factorization. +! This function is used in COBYLA, where, +! 1. Q is supplied externally (called Z); +! 2. RDIAG (the diagonal of R) is supplied externally (called ZDOTA); +! 3. A HAS FULL COLUMN RANK; +! 4. It seems that b (CGRAD and DNEW) is in the column space of A (not sure yet). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) ! A(M, N) +real(RP), intent(in) :: b(:) ! B(M) +real(RP), intent(in), optional :: Q(:, :) ! Q(M, :), SIZE(Q, 2) = M or MIN(M, N) +real(RP), intent(in), optional :: Rdiag(:) ! Rdiag(MIN(M, N)) +! Outputs +real(RP) :: x(size(A, 2)) +! Local variables +character(len=*), parameter :: srname = 'LSQR_RDIAG' +logical :: pivot +integer(IK) :: i +integer(IK) :: j +integer(IK) :: m +integer(IK) :: n +integer(IK) :: P(size(A, 2)) +integer(IK) :: rank +real(RP) :: Q_loc(size(A, 1), min(size(A, 1), size(A, 2))) +real(RP) :: Rdiag_loc(min(size(A, 1), size(A, 2))) +real(RP) :: tol +real(RP) :: y(size(b)) +real(RP) :: yq +real(RP) :: yqa + +! Sizes +m = int(size(A, 1), kind(m)) +n = int(size(A, 2), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(b) == m, 'SIZE(B) == M', srname) + if (present(Q)) then + call assert(size(Q, 1) == m .and. (size(Q, 2) == m .or. size(Q, 2) == min(m, n)), & + & 'SIZE(Q) == [M, N] .or. SIZE(Q) == [M, MIN(M, N)]', srname) + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(6, MAXPOW10) * EPS * real(max(m, n) + 1_IK, RP))) + call assert(isorth(Q, tol), 'The columns of Q are orthogonal', srname) + end if + if (present(Rdiag)) then + call assert(size(Rdiag) == min(m, n), 'SIZE(R) == MIN(M, N)', srname) + call assert(present(Q), 'Rdiag is present only if Q is present', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +if (n <= 0) then ! Of course, N < 0 should never happen. + return +end if + +if (present(Q)) then + Q_loc = Q(:, 1:size(Q_loc, 2)) + if (present(Rdiag)) then + Rdiag_loc = Rdiag + else + Rdiag_loc = [(inprod(Q_loc(:, i), A(:, i)), i=1, min(m, n))] + !!MATLAB: Rdiag_loc = sum(Q_loc(:, 1:min(m,n)) .* A(:, 1:min(m,n)), 1); % Row vector + end if + rank = min(m, n) + pivot = .false. +else + call qr(A, Q=Q_loc, P=P) + Rdiag_loc = [(inprod(Q_loc(:, i), A(:, P(i))), i=1, min(m, n))] + !!MATLAB: Rdiag_loc = sum(Q_loc(:, 1:min(m,n)) .* A(:, P(1:min(m,n))), 1); % Row vector + rank = maxval([0_IK, trueloc(abs(Rdiag_loc) > 0)]) + pivot = .true. +end if + +x = ZERO +y = b ! Local copy of B; B is INTENT(IN) and should not be modified. + +do i = rank, 1, -1 + if (pivot) then + j = P(i) + else + j = i + end if + ! The following IF comes from Powell. It forces X(J) = 0 if deviations from this value can be + ! attributed to computer rounding errors. This is a favorable choice in the context of COBYLA. + yq = inprod(y, Q_loc(:, i)) + yqa = inprod(abs(y), abs(Q_loc(:, i))) + if (isminor(yq, yqa)) then + x(j) = ZERO + else + x(j) = yq / Rdiag_loc(i) + y = y - x(j) * A(:, j) + end if +end do + +!====================! +! Calculation ends ! +!====================! + +!! Postconditions +!if (DEBUGGING) then +! ! The following test cannot be passed. +! !call assert(norm(matprod(b - matprod(A, x), A)) <= max(tol, tol * norm(matprod(b, A))), & +! ! & 'A*X is the projection of B to the column space of A', srname) +!end if +end function lsqr_Rdiag + + +function lsqr_Rfull(b, Q, R) result(x) +!--------------------------------------------------------------------------------------------------! +! This function solves the linear least squares problem min ||A*x - b||_2 by the QR factorization. +! This function is used in LINCOA, where, +! 1. The economy-size QR factorization is supplied externally (Q is called QFAC and R is called RFAC); +! 2. R is non-singular. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: b(:) ! B(M) +real(RP), intent(in) :: Q(:, :) ! Q(M, N) +real(RP), intent(in) :: R(:, :) ! R(N, N) +! Outputs +real(RP) :: x(size(R, 2)) +! Local variables +character(len=*), parameter :: srname = 'LSQR_RFULL' +integer(IK) :: i +integer(IK) :: j +integer(IK) :: m +integer(IK) :: n +real(RP) :: tol + +! Sizes +m = int(size(Q, 1), kind(m)) +n = int(size(R, 2), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= n .and. n >= 0, 'M >= N >= 0', srname) + call assert(size(b) == m, 'SIZE(B) == M', srname) + call assert(size(Q, 1) == m .and. size(Q, 2) == n, 'SIZE(Q) == [M, N]', srname) + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(6, MAXPOW10) * EPS * real(m + 1_IK, RP))) + call assert(isorth(Q, tol), 'The columns of Q are orthogonal', srname) + call assert(size(R, 1) == n .and. size(R, 2) == n, 'SIZE(R) == [N, N]', srname) + call assert(istriu(R), 'R is upper triangular', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (n <= 0) then ! Of course, N < 0 should never happen. + return +end if + +x = matprod(b, Q) +do i = n, 1, -1 + do j = i + 1_IK, n + x(i) = x(i) - R(i, j) * x(j) + end do + x(i) = x(i) / R(i, i) +end do +!--------------------------------------------------------------------------------------------------! +! The following is equivalent to the above, yet the above version works slightly better in LINCOA. +! !do i = n, 1_IK, -1_IK +! ! x(i) = (inprod(Q(:, i), b) - inprod(R(i, i + 1:n), x(i + 1:n))) / R(i, i) +! !end do +!--------------------------------------------------------------------------------------------------! + +!====================! +! Calculation ends ! +!====================! +end function lsqr_Rfull + + +function diag(A, k) result(D) +!--------------------------------------------------------------------------------------------------! +! This function takes the K-th diagonal of the matrix A, K = 0 (default) corresponding to the main +! diagonal, K > 0 above the main diagonal, and K < 0 below the main diagonal. When |K| exceeds the +! number of rows or columns in A, the function returns an empty rank-1 array. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: memory_mod, only : safealloc +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +integer(IK), intent(in), optional :: k +! Outputs +real(RP), allocatable :: D(:) +! Local variables +character(len=*), parameter :: srname = 'DIAG' +integer(IK) :: dlen +integer(IK) :: i +integer(IK) :: k_loc + +!====================! +! Calculation starts ! +!====================! + +if (present(k)) then + k_loc = k +else + k_loc = 0 +end if + +! DLEN is the length of D. We allow |K| to exceed the number of rows/columns in A. +dlen = max(0_IK, int(min(size(A, 1), size(A, 2)) - abs(k_loc), IK)) +call safealloc(D, dlen) +if (k_loc >= 0) then + D = [(A(i, i + k_loc), i=1, dlen)] +else + D = [(A(i - k_loc, i), i=1, dlen)] +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(D) == dlen, 'SIZE(D) == DLEN', srname) +end if +end function diag + + +function isbanded(A, lwidth, uwidth, tol) result(is_banded) +!--------------------------------------------------------------------------------------------------! +! This function tests whether the matrix A banded within the bandwidth specified by LWIDTH and +! UWIDTH up to the tolerance TOL. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +integer(IK), intent(in) :: lwidth +integer(IK), intent(in) :: uwidth +real(RP), intent(in), optional :: tol +! Outputs +logical :: is_banded +! Local variables +character(len=*), parameter :: srname = 'ISBANDED' +integer(IK) :: i +integer(IK) :: m +integer(IK) :: n +real(RP) :: tol_loc + +! Preconditions +if (DEBUGGING) then + call assert(lwidth >= 0 .and. uwidth >= 0, 'LWIDTH >= 0 .and. UWIDTH >= 0', srname) + if (present(tol)) then + call assert(tol >= 0, 'TOL >= 0', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +tol_loc = ZERO +if (present(tol)) then + tol_loc = max(tol, tol * maxval(abs(A))) +end if +if (is_nan(tol_loc)) then + tol_loc = ZERO +end if + +m = int(size(A, 1), kind(m)) +n = int(size(A, 2), kind(n)) + +is_banded = .true. +do i = 1, n + is_banded = (all(abs(A(i + lwidth + 1:m, i)) <= tol_loc) .and. all(abs(A(1:i - uwidth - 1, i)) <= tol_loc)) + if (.not. is_banded) then + exit + end if +end do + +!====================! +! Calculation ends ! +!====================! +end function isbanded + + +function istril(A, tol) result(is_tril) +!--------------------------------------------------------------------------------------------------! +! This function tests whether the matrix A is lower triangular up to the tolerance TOL. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +real(RP), intent(in), optional :: tol +! Outputs +logical :: is_tril +! Local variables +character(len=*), parameter :: srname = 'ISTRIL' +integer(IK) :: width +real(RP) :: tol_loc + +! Preconditions +if (DEBUGGING) then + if (present(tol)) then + call assert(tol >= 0, 'TOL >= 0', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +if (present(tol)) then + tol_loc = tol +else + tol_loc = ZERO +end if +width = int(max(0, size(A, 1) - 1), kind(width)) +is_tril = isbanded(A, width, 0_IK, tol_loc) + +!====================! +! Calculation ends ! +!====================! +end function istril + + +function istriu(A, tol) result(is_triu) +!--------------------------------------------------------------------------------------------------! +! This function tests whether the matrix A is upper triangular up to the tolerance TOL. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +real(RP), intent(in), optional :: tol +! Outputs +logical :: is_triu +! Local variables +character(len=*), parameter :: srname = 'ISTRIU' +integer(IK) :: width +real(RP) :: tol_loc + +! Preconditions +if (DEBUGGING) then + if (present(tol)) then + call assert(tol >= 0, 'TOL >= 0', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +if (present(tol)) then + tol_loc = tol +else + tol_loc = ZERO +end if +width = int(max(0, size(A, 2) - 1), kind(width)) +is_triu = isbanded(A, 0_IK, width, tol_loc) + +!====================! +! Calculation ends ! +!====================! +end function istriu + + +function isorth(A, tol) result(is_orth) +!--------------------------------------------------------------------------------------------------! +! This function tests whether the matrix A has orthonormal columns up to the tolerance TOL. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING, REALMAX, ORTHTOL_DFT +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +real(RP), intent(in), optional :: tol +! Outputs +logical :: is_orth +! Local variables +character(len=*), parameter :: srname = 'ISORTH' +integer(IK) :: n +real(RP) :: tol_loc + +! Preconditions +if (DEBUGGING) then + if (present(tol)) then + call assert(tol >= 0, 'TOL >= 0', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +tol_loc = ORTHTOL_DFT +if (present(tol)) then + tol_loc = tol +end if + +n = int(size(A, 2), kind(n)) + +! N.B. (20240304): In some cases, due to compiler bugs, we need to disable the test. We signify such +! cases by setting ORTHTOL_DFT to REALMAX. For instance, NAG Fortran Compiler Release 7.1(Hanzomon) +! Build 7143 is buggy concerning half-precision floating-point numbers. See the following: +! https://fortran-lang.discourse.group/t/nagfor-7-1-supports-half-precision-floating-point-numbers-but-with-many-bugs +is_orth = .true. +if (n > size(A, 1)) then + is_orth = .false. +elseif (any(is_nan(A))) then + is_orth = .false. +elseif (ORTHTOL_DFT < REALMAX) then + is_orth = all(abs(matprod(transpose(A), A) - eye(n)) <= max(tol_loc, tol_loc * maxval(abs(A)))) +end if + +!====================! +! Calculation ends ! +!====================! +end function isorth + + +function project1(x, v) result(y) +!--------------------------------------------------------------------------------------------------! +! This function returns the projection of X to SPAN(V). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ONE, ZERO, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_inf, is_finite, is_nan +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: v(:) +! Outputs +real(RP) :: y(size(x)) +! Local variables +character(len=*), parameter :: srname = 'PROJECT1' +real(RP) :: u(size(v)) +real(RP) :: tol + +! Preconditions +if (DEBUGGING) then + call assert(size(x) == size(v), 'SIZE(X) == SIZE(V)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (all(abs(x) <= 0) .or. all(abs(v) <= 0)) then + y = ZERO +elseif (any(is_nan(x)) .or. any(is_nan(v))) then + y = sum(x) + sum(v) ! Set Y to NaN +elseif (any(is_inf(v))) then + u = ZERO + u(trueloc(is_inf(v))) = sign(ONE, v(trueloc(is_inf(v)))) + !!MATLAB: u = 0; u(isinf(v)) = sign(v(isinf(v))) + u = u / norm(u) + y = inprod(x, u) * u +else + u = v / norm(v) + y = inprod(x, u) * u +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + if (is_finite(norm(x)) .and. is_finite(norm(v))) then + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(6, MAXPOW10) * EPS)) + call assert(norm(y) <= (ONE + tol) * norm(x), 'NORM(Y) <= NORM(X)', srname) + call assert(norm(x - y) <= (ONE + tol) * norm(x), 'NORM(X - Y) <= NORM(X)', srname) + ! The following test may not be passed. + call assert(abs(inprod(x - y, v)) <= max(tol, tol * max(norm(x - y) * norm(v), abs(inprod(x, v)))), & + & 'X - Y is orthogonal to V', srname) + end if +end if +end function project1 + + +function project2(x, V) result(y) +!--------------------------------------------------------------------------------------------------! +! This function returns the projection of X to RANGE(V). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ONE, ZERO, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_inf, is_finite, is_nan +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: V(:, :) +! Outputs +real(RP) :: y(size(x)) +! Local variables +character(len=*), parameter :: srname = 'PROJECT2' +real(RP) :: U(size(V, 1), min(size(V, 1), size(V, 2))) +real(RP) :: V_loc(size(V, 1), size(V, 2)) +real(RP) :: tol + +! Preconditions +if (DEBUGGING) then + call assert(size(x) == size(V, 1), 'SIZE(X) == SIZE(V, 1)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (size(V, 2) == 1) then + y = project1(x, V(:, 1)) +elseif (all(abs(x) <= 0) .or. all(abs(V) <= 0)) then + y = ZERO +elseif (any(is_nan(x)) .or. any(is_nan(V))) then + y = sum(x) + sum(V) ! Set Y to NaN +elseif (any(is_inf(V))) then + where (is_inf(V)) + V_loc = sign(ONE, V) + elsewhere + V_loc = ZERO + end where + !!MATLAB: V_loc = 0; V_loc(isinf(V)) = sign(V); + call qr(V_loc, Q=U) + y = matprod(U, matprod(x, U)) +else + call qr(V, Q=U) + y = matprod(U, matprod(x, U)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + if (is_finite(norm(x)) .and. is_finite(sum(V**2))) then + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(6, MAXPOW10) * EPS)) + call assert(norm(y) <= (ONE + tol) * norm(x), 'NORM(Y) <= NORM(X)', srname) + call assert(norm(x - y) <= (ONE + tol) * norm(x), 'NORM(X - Y) <= NORM(X)', srname) + ! The following test may not be passed. + call assert(norm(matprod(x - y, V)) <= max(tol, tol * max(norm(x - y) * norm(V, 'fro'), & + & norm(matprod(x, V)))), 'X - Y is orthogonal to V', srname) + end if +end if +end function project2 + + +function hypotenuse(x1, x2) result(r) +!--------------------------------------------------------------------------------------------------! +! HYPOTENUSE(X1, X2) returns SQRT(X1^2 + X2^2), handling over/underflow. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ONE, ZERO, REALMIN, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan +implicit none + +! Inputs +real(RP), intent(in) :: x1 +real(RP), intent(in) :: x2 +! Outputs +real(RP) :: r +! Local variables +character(len=*), parameter :: srname = 'HYPOTENUSE' +real(RP) :: y(2) + +!====================! +! Calculation starts ! +!====================! + +if (.not. is_finite(x1)) then + r = abs(x1) +elseif (.not. is_finite(x2)) then + r = abs(x2) +else + y = abs([x1, x2]) + y = [minval(y), maxval(y)] + if (y(1) > sqrt(REALMIN) .and. y(2) < sqrt(REALMAX / 2.1_RP)) then + r = sqrt(sum(y**2)) + elseif (y(2) > 0) then + r = y(2) * sqrt((y(1) / y(2))**2 + ONE) + else + r = ZERO + end if + ! Without the following line, R > Y(1) + Y(2) or R < Y(2) may happen due to rounding errors. + r = min(sum(y), max(y(2), r)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + if (is_nan(x1) .or. is_nan(x2)) then + call assert(is_nan(r), 'R is NaN if X1 or X2 is NaN', srname) + else + call assert(r >= abs(x1) .and. r >= abs(x2) .and. r <= abs(x1) + abs(x2), & + & 'MAX{ABS(X1), ABS(X2)} <= R <= ABS(X1) + ABS(X2)', srname) + end if +end if +end function hypotenuse + + +function planerot(x) result(G) +!--------------------------------------------------------------------------------------------------! +! As in MATLAB, PLANEROT(X) returns a 2x2 Givens matrix G for X in R^2 so that Y = G*X has Y(2) = 0. +! Roughly speaking, using a MATLAB-style formulation of matrices, +! G = [X(1)/R, X(2)/R; -X(2)/R, X(1)/R] with R = SQRT(X(1)^2+X(2)^2), and G*X = [R; 0]. +! 0. We need to take care of the possibilities of R = 0, Inf, NaN, and over/underflow. +! 1. The G defined above is continuous with respect to X except at 0. Following this definition, +! G = [sign(X(1)), 0; 0, sign(X(1))] if X(2) = 0, G = [0, sign(X(2)); -sign(X(2)), 0] if X(2) = 0. +! Yet some implementations ignore the signs, leading to discontinuity and numerical instability. +! 2. Difference from MATLAB: if X contains NaN or consists of only Inf, MATLAB returns a NaN matrix, +! but we return an identity matrix or a matrix of +/-SQRT(2). We intend to keep G always orthogonal. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ZERO, ONE, REALMIN, EPS, REALMAX, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan, is_inf +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +! Outputs +real(RP) :: G(2, 2) +! Local variables +character(len=*), parameter :: srname = 'PLANEROT' +real(RP) :: c +real(RP) :: s +real(RP) :: r +real(RP) :: t +real(RP) :: u +real(RP) :: tol + +! Preconditions +if (DEBUGGING) then + call assert(size(x) == 2, 'SIZE(X) == 2', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Define C = X(1) / R and S = X(2) / R with R = HYPOT(X(1), X(2)). Handle Inf/NaN, over/underflow. +if (any(is_nan(x))) then + ! In this case, MATLAB sets G to NaN(2, 2). We refrain from doing so to keep G orthogonal. + c = ONE + s = ZERO +elseif (all(is_inf(x))) then + ! In this case, MATLAB sets G to NaN(2, 2). We refrain from doing so to keep G orthogonal. + c = sign(1 / sqrt(2.0_RP), x(1)) + s = sign(1 / sqrt(2.0_RP), x(2)) +elseif (abs(x(1)) <= 0 .and. abs(x(2)) <= 0) then ! X(1) == 0 == X(2). + c = ONE + s = ZERO +elseif (abs(x(2)) <= EPS * abs(x(1))) then + ! N.B.: + ! 0. With <= instead of <, this case covers X(1) == 0 == X(2), which is treated above separately + ! to avoid the confusing SIGN(., 0) (see 1). + ! 1. SIGN(A, 0) = ABS(A) in Fortran but sign(0) = 0 in MATLAB, Python, Julia, and R! + ! 2. Taking SIGN(X(1)) into account ensures the continuity of G with respect to X except at 0. + c = sign(ONE, x(1)) !!MATLAB: c = sign(x(1)) + s = ZERO +elseif (abs(x(1)) <= EPS * abs(x(2))) then + ! N.B.: SIGN(A, X) = ABS(A) * sign of X /= A * sign of X ! Therefore, it is WRONG to define G + ! as SIGN(RESHAPE([ZERO, -ONE, ONE, ZERO], [2, 2]), X(2)). This mistake was committed on + ! 20211206 and took a whole day to debug! NEVER use SIGN on arrays unless you are really sure. + c = ZERO + s = sign(ONE, x(2)) !!MATLAB: s = sign(x(2)) +else + ! Here is the normal case. It implements the Givens rotation in a stable & continuous way as in: + ! Bindel, D., Demmel, J., Kahan, W., and Marques, O. (2002). On computing Givens rotations + ! reliably and efficiently. ACM Transactions on Mathematical Software (TOMS), 28(2), 206-238. + ! N.B.: 1. Modern compilers compute SQRT(REALMIN) and SQRT(REALMAX/2.1) at compilation time. + ! 2. The direct calculation without involving T and U seems to work better; use it if possible. + if (all(abs(x) > sqrt(REALMIN) .and. abs(x) < sqrt(REALMAX / 2.1_RP))) then + ! Do NOT use HYPOTENUSE here; the best implementation for one may be suboptimal for the other + r = norm(x) + c = x(1) / r + s = x(2) / r + elseif (abs(x(1)) > abs(x(2))) then + t = x(2) / x(1) + u = maxval([ONE, abs(t), sqrt(ONE + t**2)]) ! MAXVAL: precaution against rounding error. + u = sign(u, x(1)) !!MATLAB: u = sign(x(1))*sqrt(ONE + t**2) + c = ONE / u + s = t / u + else + t = x(1) / x(2) + u = maxval([ONE, abs(t), sqrt(ONE + t**2)]) ! MAXVAL: precaution against rounding error. + u = sign(u, x(2)) !!MATLAB: u = sign(x(2))*sqrt(ONE + t**2) + c = t / u + s = ONE / u + end if +end if + +G = reshape([c, -s, s, c], [2, 2]) !!MATLAB: G = [c, s; -s, c] + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(G, 1) == 2 .and. size(G, 2) == 2, 'SIZE(G) == [2, 2]', srname) + call assert(all(is_finite(G)), 'G is finite', srname) + call assert(abs(G(1, 1) - G(2, 2)) + abs(G(1, 2) + G(2, 1)) <= 0, & + & 'G(1,1) == G(2,2), G(1,2) = -G(2,1)', srname) + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, 10.0_RP**min(6, MAXPOW10) * EPS)) + call assert(isorth(G, tol), 'G is orthonormal', srname) + if (all(is_finite(x) .and. abs(x) < sqrt(REALMAX / 2.1_RP))) then + r = norm(x) + call assert(maxval(abs(matprod(G, x) - [r, ZERO])) <= max(tol, tol * r), 'G * X = [||X||, 0]', srname) + end if +end if +end function planerot + + +subroutine symmetrize(A) +!--------------------------------------------------------------------------------------------------! +! SYMMETRIZE(A) symmetrizes A. +! N.B.: Here, we assume that A is a matrix that IS SUPPOSED TO BE symmetric in precise arithmetic, +! and its asymmetry comes only from errors (e.g., rounding, noise). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! In-outputs +real(RP), intent(inout) :: A(:, :) +! Local variables +integer(IK) :: j +character(len=*), parameter :: srname = 'SYMMETRIZE' + +! Preconditions +if (DEBUGGING) then + call assert(size(A, 1) == size(A, 2), 'A is square', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! A is symmetrized by copying A(LOWER_TRI) to A(UPPER_TRI). +! N.B.: The following assumes that A(LOWER_TRI) has been properly defined. +do j = 1, int(size(A, 1), kind(j)) + A(1:j - 1, j) = A(j, 1:j - 1) +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(issymmetric(A), 'A is symmetrized', srname) +end if +end subroutine symmetrize + + +pure function isminor0(x, ref) result(is_minor) +!--------------------------------------------------------------------------------------------------! +! This function tests whether X is minor compared to REF. It is used by Powell, e.g., in COBYLA. +! In precise arithmetic, ISMINOR(X, REF) is TRUE if and only if X == 0; in floating-point +! arithmetic, ISMINOR(X, REF) is true if X is zero or its nonzero value can be attributed to +! computer rounding errors according to REF. +! Larger SENSITIVITY means the function is more strict/precise, the value TENTH being due to Powell. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, TENTH, TWO +implicit none + +! Inputs +real(RP), intent(in) :: x +real(RP), intent(in) :: ref +! Outputs +logical :: is_minor +! Local variables +real(RP), parameter :: sensitivity = TENTH +real(RP) :: refa +real(RP) :: refb + +!====================! +! Calculation starts ! +!====================! + +refa = abs(ref) + sensitivity * abs(x) +refb = abs(ref) + TWO * sensitivity * abs(x) +is_minor = (abs(ref) >= refa .or. refa >= refb) + +!====================! +! Calculation ends ! +!====================! + +end function isminor0 + + +function isminor1(x, ref) result(is_minor) +!--------------------------------------------------------------------------------------------------! +! This function tests whether X is minor compared to REF. It is used by Powell, e.g., in COBYLA. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK, RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: ref(:) +! Outputs +logical :: is_minor(size(x)) +! Local variables +character(len=*), parameter :: srname = 'ISMINOR1' +integer(IK) :: i + +! Preconditions +if (DEBUGGING) then + call assert(size(x) == size(ref), 'SIZE(X) == SIZE(REF)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +is_minor = [(isminor0(x(i), ref(i)), i=1, int(size(x), IK))] + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(is_minor) == size(x), 'SIZE(IS_MINOR) == SIZE(X)', srname) +end if +end function isminor1 + + +function issymmetric(A, tol) result(is_symmetric) +!--------------------------------------------------------------------------------------------------! +! This function tests whether A is symmetric up to TOL. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ONE, REALMAX, SYMTOL_DFT, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +real(RP), intent(in), optional :: tol +! Outputs +logical :: is_symmetric +! Local variables +character(len=*), parameter :: srname = 'ISSYMMETRIC' +real(RP) :: tol_loc + +! Preconditions +if (DEBUGGING) then + if (present(tol)) then + call assert(tol >= 0, 'TOL >= 0', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +tol_loc = SYMTOL_DFT +if (present(tol)) then + tol_loc = tol +end if + +! N.B.: +! 0. It may be expensive to take TRANSPOSE(A), let alone doing it multiple times, but this is not an +! issue in our project. We call ISSYMMETRIC only in the debugging mode, but never in production. +! 1. In Fortran, the following instructions cannot be written as the following Boolean expression: +! !IS_SYMMETRIC = (SIZE(A, 1)==SIZE(A, 2) .AND. & +! ! & ALL(IS_NAN(A) .EQV. IS_NAN(TRANSPOSE(A))) .AND. & +! ! & .NOT. ANY(ABS(A - TRANSPOSE(A)) > TOL_LOC * MAX(MAXVAL(ABS(A)), ONE))) +! This is because Fortran may not perform short-circuit evaluation of this expression. If A is not +! square, then IS_NAN(A) .EQV. IS_NAN(TRANSPOSE(A)) and A - TRANSPOSE(A) are invalid. +! 2. In addition, since Inf - Inf is NaN, we cannot replace ANY(ABS(A - TRANSPOSE(A)) > TOL_LOC ...) +! with .NOT. ALL(ABS(A - TRANSPOSE(A)) <= TOL_LOC ...). +! 3. In some cases, due to compiler bugs / features, we need to disable the test. We signify such +! cases by setting SYMTOL_DFT to REALMAX. For instance, when invoked with aggressive optimization +! options (e.g., -fast-math), gfortran 11 is buggy with ALL and ANY: ALL returns .FALSE. on a vector +! of .TRUE., while ANY returns .TRUE. on a vector of .FALSE.. In that case, we cannot test +! ALL(IS_NAN(A) .EQV. IS_NAN(TRANSPOSE(A))). +is_symmetric = .true. +if (size(A, 1) /= size(A, 2)) then + is_symmetric = .false. +elseif (SYMTOL_DFT < 0.9_RP * REALMAX) then + is_symmetric = (.not. any(abs(A - transpose(A)) > tol_loc * max(maxval(abs(A)), ONE))) .and. & + & all(is_nan(A) .eqv. is_nan(transpose(A))) +end if + +!====================! +! Calculation ends ! +!====================! +end function issymmetric + + +function p_norm(x, p) result(y) +!--------------------------------------------------------------------------------------------------! +! This function calculates the P-norm of a vector X. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ONE, TWO, ZERO, REALMIN, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert, validate +use, non_intrinsic :: infnan_mod, only : is_finite, is_posinf, is_nan +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +real(RP), intent(in), optional :: p +! Outputs +real(RP) :: y +! Local variables +character(len=*), parameter :: srname = 'P_NORM' +real(RP) :: maxabs +real(RP) :: p_loc +real(RP) :: scaling +real(RP) :: scalmax +real(RP) :: scalmin + +! Preconditions +if (present(p)) then + call validate(p >= 0, 'P >= 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (present(p)) then + p_loc = p +else + p_loc = TWO +end if + +! If SIZE(X) = 0, then MAXVAL(ABS(X)) = -HUGE(X); since we handle such a case individually, +! it is OK to write MAXVAL(ABS(X)) below, but we append 0 for robustness. +maxabs = maxval([abs(x), ZERO]) + +if (size(x) == 0) then + y = ZERO +elseif (p_loc <= 0 .and. .not. any(is_nan(x))) then + y = real(count(abs(x) > 0), kind(y)) +elseif (.not. all(is_finite(x))) then + ! If X contains NaN, then Y is NaN. Otherwise, Y is Inf when X contains +/-Inf unless P = 0. + y = sum(abs(x)) +elseif (maxabs <= 0) then + ! If MAXABS is zero, then Y is zero. Note that we do this only when X does not contain NaN. + ! Otherwise, MAXABS = 0 does not necessarily guarantee that X is all zero. + y = ZERO +else ! Now P > 0 and X is a finite-valued nonzero vector, as we have handled the other cases above. + if (is_posinf(p_loc)) then + y = maxabs + elseif (abs(p_loc - ONE) <= 0) then + y = sum(abs(x)) + elseif (abs(p_loc - TWO) <= 0) then + ! N.B.: We may use the intrinsic NORM2. Here, we use the following naive implementation + ! to get full control on the computation in a way similar to MATPROD and INPROD. + + ! To avoid over/underflow, we scale X by SCALING defined as follows if necessary. We make + ! sure SCALMIN >= MAX(REALMIN, 1/REALMAX) and SCALMAX <= MIN(REALMAX, 1/REALMIN), or we may + ! encounter over/underflow when dividing by SCALING, and even NaN if the compiler evaluates + ! 1/SCALING first, which did happen with `flang -ffast-math` on REAL32 with LLVM flang 21. + ! + ! Given a numeric model for floating-point numbers, + ! REALMIN = TINY(ZERO) = 2^{emin-1}, REALMAX = HUGE(ZERO) = (1-b^{-d})*b^{emax} >= b^{emax-1}, + ! where b = RADIX(ZERO) is the base, d = DIGITS(ZERO) > 0 is the number of base-b significant + ! digits, emin = MINEXPONENT(ZERO) & emax = MAXEXPONENT(ZERO) are the min & max exponents. + ! N.B.: IEEE 754 specifies emax and requires that emin = 1 - emax for "Binary interchange + ! floating-point formats" binary32, binary64, and binary128 (Sec. 3.3 of IEEE Std 754-2019). + ! However, mathematically, [emin, emax] defined in Fortran standards indeed corresponds to + ! [emin+1, emax+1] in IEEE 754. In addition, Fortran compilers may not implement REAL32, + ! REAL64, and REAL128 according to binary32, binary64, and binary128. For instance, + ! nagfor 7 has d = 106, emin = -968 and emax = 1023 for REAL128, while + ! IEEE 754 has d = 113, emin = -16382, and emax = 16383 for binary128. See + ! http://fortran-lang.discourse.group/t/ieee-754-binary-interchange-floating-point-formats-versus-iso-fortran-env-real-kinds + + y = sqrt(sum(x**2)) + ! The following code handles over/underflow naively. + if (is_posinf(y) .or. y <= 0) then + scalmin = real(radix(ZERO), RP)**max(minexponent(ZERO) - 1, 1 - maxexponent(ZERO)) + scalmax = real(radix(ZERO), RP)**min(maxexponent(ZERO) - 1, 1 - minexponent(ZERO)) + scaling = min(max(maxabs, scalmin), scalmax) + y = scaling * sqrt(sum((x / scaling)**2)) + end if + else + y = sum(abs(x)**p_loc)**(ONE / p_loc) + ! The following code handles over/underflow naively. + if (is_posinf(y) .or. y <= 0) then + scalmin = real(radix(ZERO), RP)**max(minexponent(ZERO) - 1, 1 - maxexponent(ZERO)) + scalmax = real(radix(ZERO), RP)**min(maxexponent(ZERO) - 1, 1 - minexponent(ZERO)) + scaling = min(max(maxabs, scalmin), scalmax) + y = scaling * sum(abs(x / scaling)**p_loc)**(ONE / p_loc) + end if + end if +end if + +!====================! +! Calculation ends ! +!====================! + +if (DEBUGGING) then + call assert(y >= 0 .or. any(is_nan(x)), 'Y >= 0 unless X contains NaN', srname) + call assert(is_nan(y) .eqv. any(is_nan(x)), 'Y is NaN if and only if X contains NaN', srname) + ! Even with scaling, Y may still be 0 if all entries of X are zero or subnormal. + call assert(y > 0 .or. any(is_nan(x)) .or. all(abs(x) < REALMIN), & + & 'Y > 0 unless X contains NaN or all its entries are below REALMIN', srname) +end if + +end function p_norm + +function named_norm_vec(x, nname) result(y) +!--------------------------------------------------------------------------------------------------! +! This function calculates named norms of a vector X. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ZERO +use, non_intrinsic :: debug_mod, only : warning +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: string_mod, only : lower, strip +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +character(len=*), intent(in) :: nname +! Outputs +real(RP) :: y +! Local variables +character(len=*), parameter :: srname = 'NAMED_NORM_VEC' + +!====================! +! Calculation starts ! +!====================! + +if (size(x) == 0) then + y = ZERO +elseif (.not. all(is_finite(x))) then + ! If X contains NaN, then Y is NaN. Otherwise, Y is Inf when X contains +/-Inf. + y = sum(abs(x)) +elseif (.not. any(abs(x) > 0)) then + ! The following is incorrect without checking the last case, as X may be all NaN. + y = ZERO +else + select case (lower(strip(nname))) + case ('fro') + y = p_norm(x) ! 2-norm, which is the default case of P_NORM. + case ('inf') + ! If SIZE(X) = 0, then MAXVAL(ABS(X)) = -HUGE(X); since we have handled such a case in the + ! above, it is OK to write Y = MAXVAL(ABS(X)) below, but we append a 0 for robustness. + y = maxval([abs(x), ZERO]) + case default + call warning(srname, 'Unknown name of norm: '//strip(nname)//'; default to the L2-norm') + y = p_norm(x) ! 2-norm, which is the default case of P_NORM. + end select +end if + +!====================! +! Calculation ends ! +!====================! +end function named_norm_vec + +function named_norm_mat(x, nname) result(y) +!--------------------------------------------------------------------------------------------------! +! This function calculates named norms of a vector X. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ZERO +use, non_intrinsic :: debug_mod, only : warning +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: string_mod, only : lower, strip +implicit none + +! Inputs +real(RP), intent(in) :: x(:, :) +character(len=*), intent(in) :: nname +! Outputs +real(RP) :: y +! Local variables +character(len=*), parameter :: srname = 'NAMED_NORM_MAT' + +!====================! +! Calculation starts ! +!====================! + +! N.B.: Ideally, we should also do a scaling similar to that in P_NORM to avoid over/underflow. + +if (size(x, 1) * size(x, 2) == 0) then + y = ZERO +elseif (.not. all(is_finite(x))) then + ! If X contains NaN, then Y is NaN. Otherwise, Y is Inf when X contains +/-Inf. + y = sum(abs(x)) +elseif (.not. any(abs(x) > 0)) then + ! The following is incorrect without checking the last case, as X may be all NaN. + y = ZERO +else + select case (lower(strip(nname))) + case ('fro') + y = sqrt(sum(x**2)) + case ('inf') + ! If SIZE(X) = 0, then MAXVAL(SUM(ABS(X), DIM=2)) = -HUGE(X); since we have handled such a + ! case in the above, it is OK to write Y = MAXVAL(SUM(ABS(X), DIM=2)) below, but we append + ! a 0 for robustness. + y = maxval([sum(abs(x), dim=2), ZERO]) + case default + call warning(srname, 'Unknown name of norm: '//strip(nname)//'; default to the Frobenius norm') + y = sqrt(sum(x**2)) + end select +end if + +!====================! +! Calculation ends ! +!====================! +end function named_norm_mat + + +function sort_i1(x, direction) result(y) +!--------------------------------------------------------------------------------------------------! +! This function sorts X according to DIRECTION, which should be 'ascend' (default) or 'descend'. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +integer(IK), intent(in) :: x(:) +character(len=*), intent(in), optional :: direction +! Outputs +integer(IK) :: y(size(x)) +! Local variables +character(len=*), parameter :: srname = 'SORT_I1' + +integer(IK) :: i +integer(IK) :: n +integer(IK) :: newn +logical :: ascending + +!====================! +! Calculation starts ! +!====================! + +ascending = .true. +if (present(direction)) then + if (direction == 'descend' .or. direction == 'DESCEND') then + ascending = .false. + end if +end if + +y = x +n = int(size(y), kind(n)) +do while (n > 1) ! Bubble sort. + newn = 0 + do i = 2, n + if ((y(i - 1) > y(i) .and. ascending) .or. (y(i - 1) < y(i) .and. .not. ascending)) then + y([i - 1_IK, i]) = y([i, i - 1_IK]) + newn = i + end if + end do + n = newn +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + if (ascending) then + call assert(all(y(1:n - 1) <= y(2:n)), 'Y is ascending', srname) + else + call assert(all(y(1:n - 1) >= y(2:n)), 'Y is descending', srname) + end if +end if +end function sort_i1 + +function sort_i2(x, dim, direction) result(y) +!--------------------------------------------------------------------------------------------------! +! This function sorts a matrix X according to DIM (1 or 2) and DIRECTION ('ascend' or 'descend'). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: consts_mod, only : IK, DEBUGGING +use, non_intrinsic :: string_mod, only : strip +implicit none + +! Inputs +integer(IK), intent(in) :: x(:, :) +integer, intent(in), optional :: dim +character(len=*), intent(in), optional :: direction +! Outputs +integer(IK) :: y(size(x, 1), size(x, 2)) +! Local variables +character(len=*), parameter :: srname = 'SORT_I2' +character(len=:), allocatable :: direction_loc +integer :: dim_loc +integer(IK) :: i +integer(IK) :: n + +!====================! +! Calculation starts ! +!====================! + +dim_loc = 1 +if (present(dim)) then + dim_loc = dim +end if + +direction_loc = 'ascend' +if (present(direction)) then + direction_loc = strip(direction) +end if + +y = x +if (dim_loc == 1) then + do i = 1, int(size(x, 2), IK) + y(:, i) = sort_i1(y(:, i), direction_loc) + end do +else + do i = 1, int(size(x, 1), IK) + y(i, :) = sort_i1(y(i, :), direction_loc) + end do +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + if (dim_loc == 1) then + n = int(size(y, 1), kind(n)) + if (direction_loc == 'ascend' .or. direction_loc == 'ASCEND') then + call assert(all(y(1:n - 1, :) <= y(2:n, :)), 'Y is ascending along dimension 1', srname) + else + call assert(all(y(1:n - 1, :) >= y(2:n, :)), 'Y is descending along dimension 1', srname) + end if + else + n = int(size(y, 2), kind(n)) + if (direction_loc == 'ascend' .or. direction_loc == 'ASCEND') then + call assert(all(y(:, 1:n - 1) <= y(:, 2:n)), 'Y is ascending along dimension 2', srname) + else + call assert(all(y(:, 1:n - 1) >= y(:, 2:n)), 'Y is descending along dimension 2', srname) + end if + end if +end if +end function sort_i2 + + +pure elemental function logical_to_int(x) result(y) +!--------------------------------------------------------------------------------------------------! +! LOGICAL_TO_INT(.TRUE.) = 1, LOGICAL_TO_INT(.FALSE.) = 0 +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK +implicit none + +! Inputs +logical, intent(in) :: x +! Outputs +integer(IK) :: y + +y = merge(tsource=1_IK, fsource=0_IK, mask=x) +end function logical_to_int + + +function trueloc(x) result(loc) +!--------------------------------------------------------------------------------------------------! +! Similar to the `find` function in MATLAB, TRUELOC returns the indices where X is true in +! the ASCENDING order. +! The motivation for this function is the fact that Fortran does not support logical indexing. See, +! for example, https: +! 1. MATLAB, Python, Julia, and R support logical indexing, so that the Fortran code Y(TRUELOC(X)) +! can simply be translated to Y(X). +! 2. If the return of TRUELOC is NOT used for indexing, its analogs in other languages are: +! MATLAB -- find, Python -- numpy.argwhere, Julia -- findall, R -- which. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: memory_mod, only : safealloc +implicit none + +! Inputs +logical, intent(in) :: x(:) +! Outputs +integer(IK), allocatable :: loc(:) ! INTEGER(IK) :: LOC(COUNT(X)) does not work with Absoft 22.0 +! Local variables +character(len=*), parameter :: srname = 'TRUELOC' +integer(IK) :: n + +!====================! +! Calculation starts ! +!====================! + +call safealloc(loc, int(count(x), IK)) ! Removable in F03. +n = int(size(x), IK) +loc = pack(linspace(1_IK, n, n), mask=x) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(all(loc >= 1 .and. loc <= n), '1 <= LOC <= N', srname) + call assert(size(loc) == count(x), 'SIZE(LOC) == COUNT(X)', srname) + call assert(all(x(loc)), 'X(LOC) is all TRUE', srname) + call assert(all(loc(2:size(loc)) > loc(1:size(loc) - 1)), 'LOC is strictly ascending', srname) +end if +end function trueloc + + +function falseloc(x) result(loc) +!--------------------------------------------------------------------------------------------------! +! FALSELOC = TRUELOC(.NOT. X) +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: memory_mod, only : safealloc +implicit none + +! Inputs +logical, intent(in) :: x(:) +! Outputs +integer(IK), allocatable :: loc(:) ! INTEGER(IK) :: LOC(COUNT(.NOT.X)) does not work with Absoft 22.0 +! Local variables +character(len=*), parameter :: srname = 'FALSELOC' + +!====================! +! Calculation starts ! +!====================! + +call safealloc(loc, int(count(.not. x), IK)) ! Removable in F03. +loc = trueloc(.not. x) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(all(loc >= 1 .and. loc <= size(x)), '1 <= LOC <= N', srname) + call assert(size(loc) == size(x) - count(x), 'SIZE(LOC) == SIZE(X) - COUNT(X)', srname) + call assert(all(.not. x(loc)), 'X(LOC) is all FALSE', srname) + call assert(all(loc(2:size(loc)) > loc(1:size(loc) - 1)), 'LOC is strictly ascending', srname) +end if +end function falseloc + + +function minimum1(x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function returns NaN if X contains NaN; otherwise, it returns MINVAL(X). Vector version. +! F2018 does not specify MINVAL(X) when X contains NaN, which motivates this function. The behavior +! of this function is the same as the following functions in various languages: +! MATLAB: min(x, [], 'includenan') +! Python: numpy.min(x) +! Julia: minimum(x) +! R: min(x) +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +! Outputs +real(RP) :: y +! Local variables +character(len=*), parameter :: srname = 'MINIMUM1' +real(RP) :: nan_test + +!====================! +! Calculation starts ! +!====================! + +!y = merge(tsource=sum(x), fsource=minval(x), mask=any(is_nan(x))) +nan_test = sum(abs(x)) ! 1. Assume: X has NaN iff NAN_TEST = NaN. 2. Avoid enormous calls to IS_NAN +y = merge(tsource=nan_test, fsource=minval(x), mask=is_nan(nan_test)) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(.not. any(x < y), 'No entry of X is smaller than Y', srname) + call assert((.not. is_nan(y)) .or. any(is_nan(x)), 'Y is not NaN unless X contains NaN', srname) + call assert(is_nan(y) .or. .not. any(is_nan(x)), 'Y is NaN if X contains NaN', srname) +end if +end function minimum1 + +function minimum2(x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function returns NaN if X contains NaN; otherwise, it returns MINVAL(X). Matrix version. +! F2018 does not specify MINVAL(X) when X contains NaN, which motivates this function. The behavior +! of this function is the same as the following functions in various languages: +! MATLAB: min(x, [], 'all', 'includenan') +! Python: numpy.min(x) +! Julia: minimum(x) +! R: min(x) +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan +implicit none + +! Inputs +real(RP), intent(in) :: x(:, :) +! Outputs +real(RP) :: y +! Local variables +character(len=*), parameter :: srname = 'MINIMUM2' +real(RP) :: nan_test + +!====================! +! Calculation starts ! +!====================! + +!y = merge(tsource=sum(x), fsource=minval(x), mask=any(is_nan(x))) +nan_test = sum(abs(x)) ! 1. Assume: X has NaN iff NAN_TEST = NaN. 2. Avoid enormous calls to IS_NAN +y = merge(tsource=nan_test, fsource=minval(x), mask=is_nan(nan_test)) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(.not. any(x < y), 'No entry of X is smaller than Y', srname) + call assert((.not. is_nan(y)) .or. any(is_nan(x)), 'Y is not NaN unless X contains NaN', srname) + call assert(is_nan(y) .or. .not. any(is_nan(x)), 'Y is NaN if X contains NaN', srname) +end if +end function minimum2 + + +function maximum1(x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function returns NaN if X contains NaN; otherwise, it returns MAXVAL(X). Vector version. +! F2018 does not specify MAXVAL(X) when X contains NaN, which motivates this function. The behavior +! of this function is the same as the following functions in various languages: +! MATLAB: max(x, [], 'includenan') +! Python: numpy.max(x) +! Julia: maximum(x) +! R: max(x) +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan +implicit none + +! Inputs +real(RP), intent(in) :: x(:) +! Outputs +real(RP) :: y +! Local variables +character(len=*), parameter :: srname = 'MAXIMUM1' +real(RP) :: nan_test + +!====================! +! Calculation starts ! +!====================! + +!y = merge(tsource=sum(x), fsource=maxval(x), mask=any(is_nan(x))) +nan_test = sum(abs(x)) ! 1. Assume: X has NaN iff NAN_TEST = NaN. 2. Avoid enormous calls to IS_NAN +y = merge(tsource=nan_test, fsource=maxval(x), mask=is_nan(nan_test)) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(.not. any(x > y), 'No entry of X is larger than Y', srname) + call assert((.not. is_nan(y)) .or. any(is_nan(x)), 'Y is not NaN unless X contains NaN', srname) + call assert(is_nan(y) .or. .not. any(is_nan(x)), 'Y is NaN if X contains NaN', srname) +end if +end function maximum1 + +function maximum2(x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function returns NaN if X contains NaN; otherwise, it returns MAXVAL(X). Matrix version. +! F2018 does not specify MAXVAL(X) when X contains NaN, which motivates this function. The behavior +! of this function is the same as the following functions in various languages: +! MATLAB: max(x, [], 'all', 'includenan') +! Python: numpy.max(x) +! Julia: maximum(x) +! R: max(x) +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan +implicit none + +! Inputs +real(RP), intent(in) :: x(:, :) +! Outputs +real(RP) :: y +! Local variables +character(len=*), parameter :: srname = 'MAXIMUM2' +real(RP) :: nan_test + +!====================! +! Calculation starts ! +!====================! + +!y = merge(tsource=sum(x), fsource=maxval(x), mask=any(is_nan(x))) +nan_test = sum(abs(x)) ! 1. Assume: X has NaN iff NAN_TEST = NaN. 2. Avoid enormous calls to IS_NAN +y = merge(tsource=nan_test, fsource=maxval(x), mask=is_nan(nan_test)) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(.not. any(x > y), 'No entry of X is larger than Y', srname) + call assert((.not. is_nan(y)) .or. any(is_nan(x)), 'Y is not NaN unless X contains NaN', srname) + call assert(is_nan(y) .or. .not. any(is_nan(x)), 'Y is NaN if X contains NaN', srname) +end if +end function maximum2 + + +function linspace_r(xstart, xstop, n) result(x) +!--------------------------------------------------------------------------------------------------! +! Similar to the function `linspace` in MATLAB and Python, this function generates N evenly spaced +! numbers, the space between the consecutive points being (XSTOP-XSTART)/(N-1). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: xstart +real(RP), intent(in) :: xstop +integer(IK), intent(in) :: n +! Outputs +real(RP) :: x(max(n, 0_IK)) +! Local variables +character(len=*), parameter :: srname = 'LINSPACE_R' +integer(IK) :: i +integer(IK) :: nm +real(RP) :: xunit + +!====================! +! Calculation starts ! +!====================! + +if (n <= 0) then ! Quick return when N <= 0. + return +end if + +nm = n - 1_IK + +if (n == 1 .or. (xstart <= xstop .and. xstop <= xstart)) then + x = xstop +elseif (abs(xstart) <= abs(xstop) .and. abs(xstop) <= abs(xstart)) then + xunit = xstop / real(nm, RP) + x = xunit * real([(i, i=-nm, nm, 2_IK)], RP) + if (modulo(nm, 2_IK) == 0) then + x(1_IK + nm / 2_IK) = ZERO + end if +else + xunit = (xstop - xstart) / real(nm, RP) + x = xstart + xunit * real([(i, i=0, nm)], RP) +end if + +if (n >= 1) then ! Indeed, N < 1 cannot happen due to the quick return when N <= 0. + x(1) = xstart + x(n) = xstop +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(x) == max(n, 0_IK), 'SIZE(X) == MAX(N, 0)', srname) +end if +end function linspace_r + +function linspace_i(xstart, xstop, n) result(x) +!--------------------------------------------------------------------------------------------------! +! This function returns INT(LINSPACE_R(REAL(XSTART, RP), REAL(XSTOP, RP), N), IK). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +integer(IK), intent(in) :: xstart +integer(IK), intent(in) :: xstop +integer(IK), intent(in) :: n +! Outputs +integer(IK) :: x(max(n, 0_IK)) +! Local variables +character(len=*), parameter :: srname = 'LINSPACE_I' + +!====================! +! Calculation starts ! +!====================! + +x = nint(linspace_r(real(xstart, RP), real(xstop, RP), n), IK) ! Rounded to the closest integer. + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(x) == max(n, 0_IK), 'SIZE(X) == MAX(N, 0)', srname) +end if +end function linspace_i + + +subroutine hessenberg_hhd_trid(A, tdiag, tsubdiag) +!--------------------------------------------------------------------------------------------------! +! This subroutine applies Householder transformations to obtain a tridiagonal matrix that is similar +! to a SYMMETRIC matrix A. The tridiagonal matrix is the Hessenberg form of A; its diagonal will be +! stored in TDIAD, and the subdiagonal in TSUBDIAG. At the return, the matrix A will be DESTROYED +! and its lower triangular part will store the Householder vectors. The code is retrieved from +! Powell's trust region subproblem solver in UOBYQA. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TWO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! In-outputs +real(RP), intent(inout) :: A(:, :) +! Outputs +real(RP), intent(out) :: tdiag(:) +real(RP), intent(out) :: tsubdiag(:) +! Local variables +character(len=*), parameter :: srname = 'HESSENBERG_HHD_TRID' +integer(IK) :: i +integer(IK) :: j +integer(IK) :: k +integer(IK) :: n +real(RP) :: Asubd +real(RP) :: colsq +real(RP) :: scaling +real(RP) :: w(size(A, 1)) +real(RP) :: wz +real(RP) :: z(size(A, 1)) +logical :: scaled + +! Sizes +n = int(size(A, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + ! Even though we only need the lower triangular part of A, we assume that, in our project, + ! something is wrong if this subroutine is invoked with a non-symmetric matrix A. + call assert(issymmetric(A), 'A is symmetric', srname) + call assert(size(tdiag) == n, 'SIZE(TDIAG) == N', srname) + call assert(size(tsubdiag) == max(0_IK, n - 1_IK), 'SIZE(TDIAG) == MAX(0, N-1)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (n <= 0) then ! Quick return when N <= 0. Of course, N < 0 is impossible. + return +end if + +! According to a test on 20220508, scaling enhances the stability and slightly improves the +! performance of UOBYQA. Indeed, when A contains huge values, NaN can occur if no scaling is applied. +scaling = maxval(abs(A)) +scaled = .false. +if (scaling <= 0) then + tdiag = ZERO + tsubdiag = ZERO + return +elseif (scaling > 1.0E8 .or. scaling < 1.0E-4) then ! The thresholds are empirical. + A = A / scaling + scaled = .true. +end if + +tdiag = diag(A) + +do k = 1, n - 1_IK + colsq = sum(A(k + 2:n, k)**2) + if (colsq <= 0) then + tsubdiag(k) = A(k + 1, k) ! A(K+1, K) may have been updated in previous loops. + A(k + 1, k) = ZERO + cycle + end if + + Asubd = A(k + 1, k) + tsubdiag(k) = sign(sqrt(colsq + Asubd**2), Asubd) + + A(k + 1, k) = -colsq / (Asubd + tsubdiag(k)) + w(k + 1:n) = sqrt(TWO / (colsq + A(k + 1, k)**2)) * A(k + 1:n, k) + !----------------------------------------------------------------------------------------------! + ! The two lines above are from Powell. They are equivalent to the following two lines. + ! !A(K + 1, K) = A(K + 1, K) - ASUBD + ! !W(K + 1:N) = sqrt(TWO) * A(K + 1:N, K) / NORM(A(K + 1:N, K)) + !----------------------------------------------------------------------------------------------! + A(k + 1:n, k) = w(k + 1:n) + + z(k + 1:n) = tdiag(k + 1:n) * w(k + 1:n) + do j = k + 1_IK, n - 1_IK + z(j + 1:n) = z(j + 1:n) + A(j + 1:n, j) * w(j) + do i = j + 1_IK, n + z(j) = z(j) + A(i, j) * w(i) + end do + end do + wz = inprod(w(k + 1:n), z(k + 1:n)) + + tdiag(k + 1:n) = tdiag(k + 1:n) + w(k + 1:n) * (wz * w(k + 1:n) - TWO * z(k + 1:n)) + do j = k + 1_IK, n + A(j + 1:n, j) = A(j + 1:n, j) - w(j + 1:n) * z(j) - w(j) * (z(j + 1:n) - wz * w(j + 1:n)) + end do +end do + +if (scaled) then + tdiag = tdiag * scaling + tsubdiag = tsubdiag * scaling +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(tdiag) == n, 'SIZE(TDIAG) == N', srname) + call assert(size(tsubdiag) == max(0_IK, n - 1_IK), 'SIZE(TDIAG) == MAX(0, N-1)', srname) +end if +end subroutine hessenberg_hhd_trid + + +subroutine hessenberg_full(A, H, Q) +!--------------------------------------------------------------------------------------------------! +! This subroutine finds a Hessenberg matrix H (all entries below the subdiagonal are 0) such that +! H = Q^T*A*Q, where Q is a orthogonal matrix that may also be returned. A will stay unchanged. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, EPS, TWO, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) +! Outputs +real(RP), intent(out) :: H(:, :) +real(RP), intent(out), optional :: Q(:, :) +! Local variables +character(len=*), parameter :: srname = 'HESSENBERG_FULL' +integer(IK) :: i +integer(IK) :: j +integer(IK) :: n +real(RP) :: colsq +real(RP) :: subd +real(RP) :: v(size(A, 1)) +real(RP) :: w(size(A, 1)) +real(RP) :: scaling +logical :: scaled + +! Debugging variables +real(RP) :: tol + +! Sizes +n = int(size(A, 1), kind(n)) + +!====================! +! Calculation starts ! +!====================! + +! Preconditions +if (DEBUGGING) then + call assert(size(A, 1) == size(A, 2), 'A is square', srname) + call assert(size(H, 1) == n .and. size(H, 2) == n, 'SIZE(H) == [N, N]', srname) + if (present(Q)) then + call assert(size(Q, 1) == n .and. size(Q, 2) == n, 'SIZE(Q) == [N, N]', srname) + end if +end if + +if (n <= 0) then ! Quick return when N <= 0. Of course, N < 0 is impossible. + return +end if + +H = A +if (present(Q)) then + Q = eye(n) +end if + +! According to a test on 20220508, scaling enhances the stability and slightly improves the +! performance of UOBYQA. Indeed, when A contains huge values, NaN can occur if no scaling is applied. +scaling = maxval(abs(H)) +scaled = .false. +if (scaling <= 0) then + return +elseif (scaling > 1.0E6 .or. scaling < 1.0E-6) then ! 1.0E6 and 1.0E-6 are heuristic. + H = H / scaling + scaled = .true. +end if + +do j = 1, n - 1_IK + colsq = sum(H(j + 2:n, j)**2) + if (colsq <= 0) then + cycle + end if + + v(j + 1:n) = H(j + 1:n, j) + subd = sign(sqrt(v(j + 1)**2 + colsq), v(j + 1)) + + !----------------------------------------------------------------------------------------------! + v(j + 1) = -colsq / (v(j + 1) + subd) + v(j + 1:n) = sqrt(TWO / (colsq + v(j + 1)**2)) * v(j + 1:n) + ! The two lines above are from Powell. They are equivalent to the following two lines. + ! !V(J + 1) = V(J + 1) - SUBD + ! !V(J + 1:N) = sqrt(TWO) * V(J + 1:N) / NORM(V(J + 1:N)) + !----------------------------------------------------------------------------------------------! + + do i = j + 1_IK, n + H(j + 1:n, i) = H(j + 1:n, i) - inprod(H(j + 1:n, i), v(j + 1:n)) * v(j + 1:n) + end do + H(j + 1, j) = subd + H(j + 2:n, j) = ZERO + + w = matprod(H(:, j + 1:n), v(j + 1:n)) + do i = j + 1_IK, n + H(:, i) = H(:, i) - w * v(i) + end do + + if (present(Q)) then + w = matprod(Q(:, j + 1:n), v(j + 1:n)) + do i = j + 1_IK, n + Q(:, i) = Q(:, i) - w * v(i) + end do + end if +end do + +if (scaled) then + H = H * scaling +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(H, 1) == n .and. size(H, 2) == n, 'SIZE(H) == [N, N]', srname) + call assert(isbanded(H, 1_IK, n - 1_IK), 'H is a Hessenberg matrix', srname) + tol = max(TEN**max(-8, -MAXPOW10), min(1.0E-1_RP, TEN**min(10, MAXPOW10) * EPS * real(n, RP))) + call assert(issymmetric(H, tol) .or. .not. issymmetric(A), 'H is symmetric if so is A', srname) + if (present(Q)) then + call assert(size(Q, 1) == n .and. size(Q, 2) == n, 'SIZE(Q) == [N, N]', srname) + call assert(isorth(Q, tol), 'Q is orthogonal', srname) + call assert(all(abs(matprod(Q, H) - matprod(A, Q)) <= tol * maxval(abs(A))), 'Q*H = A*Q', srname) + end if +end if +end subroutine hessenberg_full + + +function eigmin_sym_trid(td, tn, tol) result(eig_min) +!--------------------------------------------------------------------------------------------------! +! This function approximates the smallest eigenvalue EIG_MIN of a symmetric tridiagonal matrix by a +! bisection method, in which process EMINLB is a lower bound on EIG_MIN and EMINUB an upper bound. +! TD is the diagonal of the tridiagonal matrix, and TN is the subdiagonal and superdiagonal. EMINUB +! is occasionally adjusted by the rule of false position (https: +! which attempts to accelerate the bisection by linear interpolation. The code is retrieved from +! Powell's trust region subproblem solver in UOBYQA. +! +! The bisection algorithm for eigenvalues (not only the smallest) of symmetric tridiagonal matrices +! can be found in +! Barth, Martin, and Wilkinson, Calculation of the eigenvalues of a symmetric tridiagonal matrix by +! the method of bisection, Numerische Mathematik 9, 386--393 (1967). +! The algorithm is based on the sign changes of the Sturm sequence {P_i(LAMBDA)} defined in (1)--(2) +! of the above mentioned paper (P_i(LAMBDA) is the determinant of the i-th principle submatrix of +! the matrix minus LAMBDA*I), or the number of negative values of the Sturm-ratio sequence +! {Q_i(LAMBDA) = P_i(LAMBDA)/P_{i-1}(LAMBDA)} in (3)--(5) of the paper. The theoretical basis is the +! following fact: for any symmetric tridiagonal n-by-n matrix A, the number of negative eigenvalues +! is equal to the number of sign changes in the Sturm sequence 1, det(A^(1)), det(A^(2)), ..., +! det(A^(n)), where A^(i) is the i-th principle submatrix of A, where a "sign change" is a transition +! from nonpositive to positive or from nonnegative to negative (see, e.g., pages 228--229 of +! Trefethen-Bau 1997, Numerical Linear Algebra, or pages 300--301 of Wilkinson 1965, The Algebraic +! Eigenvalue Problem). +! +! In MATLAB/Python/Julia/R, to get the smallest eigenvalue, we should use the eigenvalue computation +! function built in the languages or standard libraries. For example, in MATLAB, we can do +! !tridh = spdiags([[tn; 0], td, [0; tn]], -1:1, n, n); +! !crvmin = eigs(tridh, 1, 'smallestreal'); +! !% It is critical for the efficiency to use `spdiags` to construct `tridh` in the sparse form. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, HALF, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: td(:) +real(RP), intent(in) :: tn(:) +real(RP), intent(in), optional :: tol +! Outputs +real(RP) :: eig_min +! Local variables +character(len=*), parameter :: srname = 'EIGMIN' +integer(IK) :: iter +integer(IK) :: k +integer(IK) :: ksav +integer(IK) :: maxiter +integer(IK) :: n +real(RP) :: eminlb +real(RP) :: eminub +real(RP) :: piv(size(td)) +real(RP) :: pivksv +real(RP) :: pivnew(size(td)) +real(RP) :: tol_loc + +! Sizes +n = int(size(td), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(tn) == n - 1, 'SIZE(TN) == N - 1', srname) + if (present(tol)) then + call assert(tol >= 0, 'TOL >= 0', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +maxiter = 100 +tol_loc = TEN**max(-6, -MAXPOW10) +if (present(tol)) then + tol_loc = tol +end if + +! The following loop calculates the Sturm ratios [Q_1(0), ..., Q_n(0)]. These ratios are all positive +! iff all the eigenvalues of the matrix are positive definite. Note that these ratios are also the +! pivots of the Cholesky factorization of the matrix (i.e., the square of the diagonal of L in LL^T, +! or the diagonal of D in LDL^T). All the pivots are positive iff there exists a Cholesky +! factorization with a positive diagonal, i.e., the matrix is positive definite. +piv = -ONE +piv(1) = td(1) +do k = 1, n - 1_IK + if (piv(k) > 0) then + piv(k + 1) = td(k + 1) - tn(k)**2 / piv(k) + else + exit + end if +end do + +if (all(piv >= 0)) then ! The matrix is positive semidefinite. + eminub = minval(piv) + eminlb = ZERO +else + eminub = minval(td) + eminlb = -maxval(abs([ZERO, tn]) + abs(td) + abs([tn, ZERO])) +end if + +ksav = 0 +pivksv = ZERO ! This initial value will not be used, but Fortran compilers may complain without it. +do iter = 1, maxiter ! Powell's code is essentially a DO WHILE loop. We impose an explicit MAXITER. + if (eminub - eminlb <= tol_loc * max(abs(eminlb), abs(eminub))) then + exit + end if + eig_min = HALF * (eminlb + eminub) + + ! The following loop calculates the Sturm ratios [Q_1(EIG_MIN), ..., Q_n(EIG_MIN)]. These ratios + ! are all positive iff all the eigenvalues of the matrix are larger than EIG_MIN, i.e., EIG_MIN + ! underestimates the smallest eigenvalue. Note that these ratios are also the pivots of the + ! Cholesky factorization of the matrix minus EIG_MIN*I (i.e., the square of the diagonal of L in + ! LL^T, or the diagonal of D in LDL^T). All the pivots are positive iff there exists a Cholesky + ! factorization with a positive diagonal, i.e., the matrix minus LAMBDA*I is positive definite. + pivnew = -ONE + pivnew(1) = td(1) - eig_min + do k = 1, n - 1_IK + if (pivnew(k) > 0) then + pivnew(k + 1) = td(k + 1) - eig_min - tn(k)**2 / pivnew(k) + else + exit + end if + end do + + if (all(pivnew > 0)) then + piv = pivnew + eminlb = eig_min + cycle + end if + + ! We arrive here iff PIVNEW contains nonpositive entries and EIG_MIN is no less than the smallest + ! eigenvalue. We set EMINUB to EIG_MIN except a possible adjustment by the rule of false position. + k = minval(trueloc(.not. pivnew > 0)) + piv(1:k - 1) = pivnew(1:k - 1) + + ! KSAV was initialized to 0, triggering the ELSE when ALL(PIVNEW > 0) fails for the first time. + if (k == ksav .and. pivksv < 0 .and. piv(k) - pivnew(k) >= pivnew(k) - pivksv) then + pivksv = ZERO + eminub = (eig_min * piv(k) - eminlb * pivnew(k)) / (piv(k) - pivnew(k)) + else + ksav = k + pivksv = pivnew(k) ! PIVKSAV <= 0. + eminub = eig_min + end if + + !----------------------------------------------------------------------------------------------! + ! Powell's original code contains the following, why? It seems to cause wrong outputs sometimes. + ! Zaikun 20220511: Does this affect the adjustment by the rule of false position? + ! !IF (K < KSAV .OR. (K == KSAV .AND. PIVKSV == 0)) EXIT + !----------------------------------------------------------------------------------------------! +end do + +eig_min = eminlb + +!====================! +! Calculation ends ! +!====================! +end function eigmin_sym_trid + + +function vec2smat(vec) result(smat) +!--------------------------------------------------------------------------------------------------! +! This function transforms a vector VEC to a symmetric matrix SMAT with the vector storing the upper +! triangular part of the matrix column by column. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none +! Inputs +real(RP), intent(in) :: vec(:) +! Outputs +real(RP) :: smat((nint(sqrt(real(8 * size(vec) + 1))) - 1) / 2, (nint(sqrt(real(8 * size(vec) + 1))) - 1) / 2) +! Local variables +character(len=*), parameter :: srname = 'SMAT2VEC' +integer(IK) :: ih +integer(IK) :: j +integer(IK) :: n + +! Sizes +n = int(size(smat, 1), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(vec) == n * (n + 1) / 2, 'SIZE(VEC) = N*(N+1)/2', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +do j = 1, n + ih = (j - 1_IK) * j / 2_IK + smat(1:j, j) = vec(ih + 1:ih + j) + smat(j, 1:j - 1) = smat(1:j - 1, j) +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(issymmetric(smat), 'SMAT is symmetric', srname) +end if +end function vec2smat + + +function smat2vec(smat) result(vec) +!--------------------------------------------------------------------------------------------------! +! This function transforms a symmetric matrix SMAT to a vector VEC that stores the upper triangular +! part of the matrix column by column. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none +! Inputs +real(RP), intent(in) :: smat(:, :) +! Outputs +real(RP) :: vec((size(smat, 1) * (size(smat, 1) + 1)) / 2) +! Local variables +character(len=*), parameter :: srname = 'SMAT2VEC' +integer(IK) :: ih +integer(IK) :: n +integer(IK) :: j + +! Preconditions +if (DEBUGGING) then + call assert(issymmetric(smat), 'SMAT is symmetric', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +n = int(size(smat, 1), kind(n)) +do j = 1, n + ih = (j - 1_IK) * j / 2_IK + vec(ih + 1:ih + j) = smat(1:j, j) +end do + +!====================! +! Calculation ends ! +!====================! + +end function smat2vec + + +function smat_mul_vec(smatv, x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function calculates the product of a symmetric matrix and a vector X, with the upper +! triangular part of the matrix stored in the vector SMATV column by column. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none +! Inputs +real(RP), intent(in) :: smatv(:) +real(RP), intent(in) :: x(:) +! Outputs +real(RP) :: y(size(x)) +! Local variables +character(len=*), parameter :: srname = 'SMAT_MUL_VEC' +integer(IK) :: ih +integer(IK) :: n +integer(IK) :: j + +! Sizes +n = int(size(x), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(smatv) == n * (n + 1_IK) / 2_IK, 'SIZE(SMATV) = N*(N+1)/2', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +do j = 1, n + ih = (j - 1_IK) * j / 2_IK + y(j) = inprod(smatv(ih + 1:ih + j), x(1:j)) + y(1:j - 1) = y(1:j - 1) + x(j) * smatv(ih + 1:ih + j - 1) +end do + +!====================! +! Calculation ends ! +!====================! + +end function smat_mul_vec + + +end module linalg_mod diff --git a/examples/fortran/prima/native/common/memory.F90 b/examples/fortran/prima/native/common/memory.F90 new file mode 100644 index 000000000..c5fce181d --- /dev/null +++ b/examples/fortran/prima/native/common/memory.F90 @@ -0,0 +1,561 @@ +#include "ppf.h" + +module memory_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning memory management. +! +! In particular, the intrinsic ALLOCATE is wrapped into the procedure SAFEALLOC, which may be a +! controversial practice. We choose to do this because it has helped us a couple of times to locate +! bugs or problems in our code or even in compilers (e.g., Absoft). See the below for discussions: +! https://fortran-lang.discourse.group/t/best-practice-of-allocating-memory-in-fortran +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020 +! +! Last Modified: Wednesday, February 28, 2024 AM12:20:23 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: cstyle_sizeof +public :: safealloc + +interface cstyle_sizeof + module procedure size_of_sp, size_of_dp +#if PRIMA_HP_AVAILABLE == 1 + module procedure size_of_hp +#endif +#if PRIMA_QP_AVAILABLE == 1 + module procedure size_of_qp +#endif +end interface cstyle_sizeof + +interface safealloc + module procedure alloc_lvector + module procedure alloc_ivector, alloc_imatrix + module procedure alloc_rvector_sp, alloc_rmatrix_sp + module procedure alloc_rvector_dp, alloc_rmatrix_dp + module procedure alloc_character +#if PRIMA_HP_AVAILABLE == 1 + module procedure alloc_rvector_hp, alloc_rmatrix_hp +#endif +#if PRIMA_QP_AVAILABLE == 1 + module procedure alloc_rvector_qp, alloc_rmatrix_qp +#endif +end interface safealloc + + +contains + + +pure function size_of_sp(x) result(y) +!--------------------------------------------------------------------------------------------------! +! Return the storage size of X in Bytes, X being a REAL(SP) scalar. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : SP, IK +implicit none +! Inputs +real(SP), intent(in) :: x +! Outputs +integer(IK) :: y + +! We prefer STORAGE_SIZE to C_SIZEOF, because the former is intrinsic while the later requires the +! intrinsic module ISO_C_BINDING. +y = int(storage_size(x) / 8, kind(y)) ! Y = INT(C_SIZEOF(X), KIND(Y)) +end function size_of_sp + + +pure function size_of_dp(x) result(y) +!--------------------------------------------------------------------------------------------------! +! Return the storage size of X in Bytes, X being a REAL(DP) scalar. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : DP, IK +implicit none +! Inputs +real(DP), intent(in) :: x +! Outputs +integer(IK) :: y + +y = int(storage_size(x) / 8, kind(y)) +end function size_of_dp + + +#if PRIMA_HP_AVAILABLE == 1 + +pure function size_of_hp(x) result(y) +!--------------------------------------------------------------------------------------------------! +! Return the storage size of X in Bytes, X being a REAL(HP) scalar. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : HP, IK +implicit none +! Inputs +real(HP), intent(in) :: x +! Outputs +integer(IK) :: y + +y = int(storage_size(x) / 8, kind(y)) +end function size_of_hp + +#endif + + +#if PRIMA_QP_AVAILABLE == 1 + +pure function size_of_qp(x) result(y) +!--------------------------------------------------------------------------------------------------! +! Return the storage size of X in Bytes, X being a REAL(QP) scalar. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : QP, IK +implicit none +! Inputs +real(QP), intent(in) :: x +! Outputs +integer(IK) :: y + +y = int(storage_size(x) / 8, kind(y)) +end function size_of_qp + +#endif + + +subroutine alloc_rvector_sp(x, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable REAL(SP) vector X, whose size is N after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : SP, IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: n + +! Outputs +real(SP), allocatable, intent(out) :: x(:) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_RVECTOR_SP' + +! Preconditions (checked even not debugging) +call validate(n >= 0, 'N >= 0', srname) + +! According to the Fortran 2003 standard, when a procedure is invoked, any allocated ALLOCATABLE +! object that is an actual argument associated with an INTENT(OUT) ALLOCATABLE dummy argument is +! deallocated. So the following line is unnecessary since F2003 as X is INTENT(OUT): +! !if (allocated(x)) deallocate (x) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:n), stat=alloc_status) +x = -huge(x) ! Costly if X is of a large size. +! N.B.: Do not write ALLOCATE (X(1:N), STAT=ALLOC_STATUS, SOURCE=-HUGE(X)), because +! 1. It is invalid to put X in the SOURCE specifier when it is being allocated; +! 2. Absoft does not support the SOURCE keyword as of 2022. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x) == n, 'SIZE(X) == N', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == n, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == N', srname) +end subroutine alloc_rvector_sp + + +subroutine alloc_rmatrix_sp(x, m, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable REAL(SP) matrix X, whose size is (M, N) after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : SP, IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: m, n + +! Outputs +real(SP), allocatable, intent(out) :: x(:, :) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_RMATRIX_SP' + +! Preconditions (checked even not debugging) +call validate(m >= 0 .and. n >= 0, 'M >= 0, N >= 0', srname) + +!if (allocated(x)) deallocate (x) ! Unnecessary in F03 since X is INTENT(OUT) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:m, 1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = -huge(x) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x, 1) == m .and. size(x, 2) == n, 'SIZE(X) == [M, N]', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == m, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == M', srname) +call validate(lbound(x, 2) == 1 .and. ubound(x, 2) == n, 'LBOUND(X, 2) == 1, UBOUND(X, 2) == N', srname) +end subroutine alloc_rmatrix_sp + + +subroutine alloc_rvector_dp(x, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable REAL(DP) vector X, whose size is N after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : DP, IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: n + +! Outputs +real(DP), allocatable, intent(out) :: x(:) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_RVECTOR_DP' + +! Preconditions (checked even not debugging) +call validate(n >= 0, 'N >= 0', srname) + +! According to the Fortran 2003 standard, when a procedure is invoked, any allocated ALLOCATABLE +! object that is an actual argument associated with an INTENT(OUT) ALLOCATABLE dummy argument is +! deallocated. So the following line is unnecessary since F2003 as X is INTENT(OUT): +! !if (allocated(x)) deallocate (x) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = -huge(x) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x) == n, 'SIZE(X) == N', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == n, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == N', srname) +end subroutine alloc_rvector_dp + + +subroutine alloc_rmatrix_dp(x, m, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable REAL(DP) matrix X, whose size is (M, N) after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : DP, IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: m, n + +! Outputs +real(DP), allocatable, intent(out) :: x(:, :) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_RMATRIX_DP' + +! Preconditions (checked even not debugging) +call validate(m >= 0 .and. n >= 0, 'M >= 0, N >= 0', srname) + +!if (allocated(x)) deallocate (x) ! Unnecessary in F03 since X is INTENT(OUT) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:m, 1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = -huge(x) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x, 1) == m .and. size(x, 2) == n, 'SIZE(X) == [M, N]', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == m, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == M', srname) +call validate(lbound(x, 2) == 1 .and. ubound(x, 2) == n, 'LBOUND(X, 2) == 1, UBOUND(X, 2) == N', srname) +end subroutine alloc_rmatrix_dp + + +#if PRIMA_HP_AVAILABLE == 1 + +subroutine alloc_rvector_hp(x, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable REAL(HP) vector X, whose size is N after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : HP, IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: n + +! Outputs +real(HP), allocatable, intent(out) :: x(:) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_RVECTOR_HP' + +! Preconditions (checked even not debugging) +call validate(n >= 0, 'N >= 0', srname) + +! According to the Fortran 2003 standard, when a procedure is invoked, any allocated ALLOCATABLE +! object that is an actual argument associated with an INTENT(OUT) ALLOCATABLE dummy argument is +! deallocated. So the following line is unnecessary since F2003 as X is INTENT(OUT): +! !if (allocated(x)) deallocate (x) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = -huge(x) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x) == n, 'SIZE(X) == N', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == n, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == N', srname) +end subroutine alloc_rvector_hp + + +subroutine alloc_rmatrix_hp(x, m, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable REAL(HP) matrix X, whose size is (M, N) after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : HP, IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: m, n + +! Outputs +real(HP), allocatable, intent(out) :: x(:, :) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_RMATRIX_HP' + +! Preconditions (checked even not debugging) +call validate(m >= 0 .and. n >= 0, 'M >= 0, N >= 0', srname) + +! !if (allocated(x)) deallocate (x) ! Unnecessary in F03 since X is INTENT(OUT) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:m, 1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = -huge(x) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x, 1) == m .and. size(x, 2) == n, 'SIZE(X) == [M, N]', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == m, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == M', srname) +call validate(lbound(x, 2) == 1 .and. ubound(x, 2) == n, 'LBOUND(X, 2) == 1, UBOUND(X, 2) == N', srname) +end subroutine alloc_rmatrix_hp + +#endif + + +#if PRIMA_QP_AVAILABLE == 1 + +subroutine alloc_rvector_qp(x, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable REAL(QP) vector X, whose size is N after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : QP, IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: n + +! Outputs +real(QP), allocatable, intent(out) :: x(:) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_RVECTOR_QP' + +! Preconditions (checked even not debugging) +call validate(n >= 0, 'N >= 0', srname) + +! According to the Fortran 2003 standard, when a procedure is invoked, any allocated ALLOCATABLE +! object that is an actual argument associated with an INTENT(OUT) ALLOCATABLE dummy argument is +! deallocated. So the following line is unnecessary since F2003 as X is INTENT(OUT): +! !if (allocated(x)) deallocate (x) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = -huge(x) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x) == n, 'SIZE(X) == N', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == n, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == N', srname) +end subroutine alloc_rvector_qp + + +subroutine alloc_rmatrix_qp(x, m, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable REAL(QP) matrix X, whose size is (M, N) after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : QP, IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: m, n + +! Outputs +real(QP), allocatable, intent(out) :: x(:, :) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_RMATRIX_QP' + +! Preconditions (checked even not debugging) +call validate(m >= 0 .and. n >= 0, 'M >= 0, N >= 0', srname) + +! !if (allocated(x)) deallocate (x) ! Unnecessary in F03 since X is INTENT(OUT) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:m, 1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = -huge(x) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x, 1) == m .and. size(x, 2) == n, 'SIZE(X) == [M, N]', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == m, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == M', srname) +call validate(lbound(x, 2) == 1 .and. ubound(x, 2) == n, 'LBOUND(X, 2) == 1, UBOUND(X, 2) == N', srname) +end subroutine alloc_rmatrix_qp + +#endif + + +subroutine alloc_lvector(x, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable LOGICAL vector X, whose size is N after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: n + +! Outputs +logical, allocatable, intent(out) :: x(:) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_LVECTOR' + +! Preconditions (checked even not debugging) +call validate(n >= 0, 'N >= 0', srname) + +! !if (allocated(x)) deallocate (x) ! Unnecessary in F03 since X is INTENT(OUT) +! Allocate memory for X. Initialize X to a compiler-independent value. +allocate (x(1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = .false. ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x) == n, 'SIZE(X) == N', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == n, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == N', srname) +end subroutine alloc_lvector + + +subroutine alloc_ivector(x, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable INTEGER(IK) vector X, whose size is N after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: n + +! Outputs +integer(IK), allocatable, intent(out) :: x(:) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_IVECTOR' + +! Preconditions (checked even not debugging) +call validate(n >= 0, 'N >= 0', srname) + +! !if (allocated(x)) deallocate (x) ! Unnecessary in F03 since X is INTENT(OUT) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = -huge(x) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x) == n, 'SIZE(X) == N', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == n, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == N', srname) +end subroutine alloc_ivector + + +subroutine alloc_imatrix(x, m, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for a INTEGER(IK) matrix X, whose size is (M, N) after allocation. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer(IK), intent(in) :: m, n + +! Outputs +integer(IK), allocatable, intent(out) :: x(:, :) + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_IMATRIX' + +! Preconditions (checked even not debugging) +call validate(m >= 0 .and. n >= 0, 'M >= 0, N >= 0', srname) + +! !if (allocated(x)) deallocate (x) ! Unnecessary in F03 since X is INTENT(OUT) +! Allocate memory for X. Initialize X to a compiler-independent strange value. +allocate (x(1:m, 1:n), stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = -huge(x) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(size(x, 1) == m .and. size(x, 2) == n, 'SIZE(X) == [M, N]', srname) +call validate(lbound(x, 1) == 1 .and. ubound(x, 1) == m, 'LBOUND(X, 1) == 1, UBOUND(X, 1) == M', srname) +call validate(lbound(x, 2) == 1 .and. ubound(x, 2) == n, 'LBOUND(X, 2) == 1, UBOUND(X, 2) == N', srname) +end subroutine alloc_imatrix + + +subroutine alloc_character(x, n) +!--------------------------------------------------------------------------------------------------! +! Allocate space for an allocatable character X, whose length is N after allocation. +! N.B.: Here, we implement only the version with N being the default integer, even if IK = INT16. It +! is unsafe to use INT16 as the length of a character variable. It may cause overflow in real2str, +! as a double-precision vector of length ~3500 would be printed as a string longer than 65536. +! On most modern platforms, the default integer kind is INT32, which is enough for printing +! double-precision vectors of size ~ 10^8, being sufficient for this project. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: debug_mod, only : validate +implicit none + +! Inputs +integer, intent(in) :: n + +! Outputs +character(len=:), allocatable, intent(out) :: x + +! Local variables +integer :: alloc_status +character(len=*), parameter :: srname = 'ALLOC_CHARACTER' + +! Preconditions (checked even not debugging) +call validate(n >= 0, 'N >= 0', srname) + +! !if (allocated(x)) deallocate (x) ! Unnecessary in F03 since X is INTENT(OUT) +! Allocate memory for X. Initialize X to a compiler-independent value. +allocate (character(len=n) :: x, stat=alloc_status) ! Absoft does not support the SOURCE keyword as of 2022. +x = repeat(' ', ncopies=n) ! Costly if X is of a large size. + +! Postconditions (checked even not debugging) +call validate(alloc_status == 0, 'Memory allocation succeeds (ALLOC_STATUS == 0)', srname) +call validate(allocated(x), 'X is allocated', srname) +call validate(len(x) == n, 'LEN(X) == N', srname) +end subroutine alloc_character + + +end module memory_mod diff --git a/examples/fortran/prima/native/common/message.f90 b/examples/fortran/prima/native/common/message.f90 new file mode 100644 index 000000000..5199dc6ff --- /dev/null +++ b/examples/fortran/prima/native/common/message.f90 @@ -0,0 +1,447 @@ +module message_mod +!--------------------------------------------------------------------------------------------------! +! This module provides some subroutines that print messages to terminal/files. +! +! N.B.: +! 1. In case parallelism is desirable (especially during initialization), the subroutines may +! have to be modified or disabled due to the IO operations. +! 2. IPRINT indicates the level of verbosity, which increases with the absolute value of IPRINT. +! IPRINT = +/-3 can be expensive due to high IO operations. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and papers. +! +! Started: July 2020 +! +! Last Modified: Sunday, March 31, 2024 PM04:55:58 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: retmsg, rhomsg, fmsg, cpenmsg + +character(len=3), parameter :: spaces = ' ' + +contains + + +subroutine retmsg(solver, info, iprint, nf, f, x, cstrv, constr) +!--------------------------------------------------------------------------------------------------! +! This subroutine prints messages at return. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, STDOUT, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: fprint_mod, only : fprint +use, non_intrinsic :: infos_mod, only : FTARGET_ACHIEVED, MAXFUN_REACHED, MAXTR_REACHED, & + & SMALL_TR_RADIUS, TRSUBP_FAILED, NAN_INF_X, NAN_INF_F, NAN_INF_MODEL, DAMAGING_ROUNDING, & + & NO_SPACE_BETWEEN_BOUNDS, ZERO_LINEAR_CONSTRAINT, CALLBACK_TERMINATE +use, non_intrinsic :: linalg_mod, only : maximum +use, non_intrinsic :: string_mod, only : strip, num2str +implicit none + +! Compulsory inputs +character(len=*), intent(in) :: solver +integer(IK), intent(in) :: info +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: nf +real(RP), intent(in) :: f +real(RP), intent(in) :: x(:) + +! Optional inputs +real(RP), intent(in), optional :: cstrv +real(RP), intent(in), optional :: constr(:) + +! Local variables +character(len=*), parameter :: newline = new_line('') +character(len=*), parameter :: srname = 'RETMSG' +character(len=:), allocatable :: constr_message +character(len=:), allocatable :: fname +character(len=:), allocatable :: message +character(len=:), allocatable :: nf_message +character(len=:), allocatable :: reason +character(len=:), allocatable :: ret_message +character(len=:), allocatable :: x_message +integer :: funit ! File storage unit for the writing. Should be an integer of default kind. +integer(IK), parameter :: valid_exit_flags(11) = [FTARGET_ACHIEVED, MAXFUN_REACHED, MAXTR_REACHED, & + & SMALL_TR_RADIUS, TRSUBP_FAILED, NAN_INF_F, NAN_INF_X, NAN_INF_MODEL, DAMAGING_ROUNDING, & + & NO_SPACE_BETWEEN_BOUNDS, ZERO_LINEAR_CONSTRAINT] +logical :: is_constrained +real(RP) :: cstrv_loc + +! Preconditions +if (DEBUGGING) then + call assert(any(info == valid_exit_flags), 'The exit flag is valid', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (abs(iprint) < 1) then ! No printing + return +elseif (iprint > 0) then ! Print the message to the standard out. + funit = STDOUT + fname = '' +else ! Print the message to a file named FNAME. + fname = strip(solver)//'_output.txt' +end if + +! Decide whether the problem is truly constrained. +if (present(constr)) then + is_constrained = (size(constr) > 0) +else + is_constrained = present(cstrv) +end if + +! Decide the constraint violation. +if (present(cstrv)) then + cstrv_loc = cstrv +elseif (present(constr)) then + cstrv_loc = maximum([ZERO, -constr]) ! N.B.: We assume that the constraint is CONSTR >= 0. +else + cstrv_loc = ZERO +end if + +! Decide the return message. +select case (info) +case (FTARGET_ACHIEVED) + reason = 'the target function value is achieved.' +case (MAXFUN_REACHED) + reason = 'the maximal number of function evaluations has been reached.' +case (MAXTR_REACHED) + reason = 'the maximal number of trust region iterations has been reached.' +case (SMALL_TR_RADIUS) + reason = 'the trust region radius reaches its lower bound.' +case (TRSUBP_FAILED) + reason = 'a trust region step has failed to reduce the quadratic model.' +case (NAN_INF_X) + reason = 'NaN or Inf occurs in x.' +case (NAN_INF_F) + reason = 'the objective or constraint functions return NaN or +Inf.' +case (NAN_INF_MODEL) + reason = 'NaN or Inf occurs in the models.' +case (DAMAGING_ROUNDING) + reason = 'rounding errors are becoming damaging.' +case (NO_SPACE_BETWEEN_BOUNDS) + reason = 'there is no space between the lower and upper bounds of variable.' +case (ZERO_LINEAR_CONSTRAINT) + reason = 'one of the linear constraints has a zero gradient' +case (CALLBACK_TERMINATE) + reason = 'callback function requested termination of optimization' +case default + reason = 'UNKNOWN EXIT FLAG' +end select +ret_message = newline//'Return from '//solver//' because '//strip(reason) + +if (size(x) <= 2) then + x_message = newline//'The corresponding X is: '//num2str(x) ! Printed in one line +else + x_message = newline//'The corresponding X is:'//newline//num2str(x) +end if + +if (is_constrained) then + nf_message = newline//'Number of function values = '//num2str(nf)//spaces// & + & 'Least value of F = '//num2str(f)//spaces//'Constraint violation = '//num2str(cstrv_loc) +else + nf_message = newline//'Number of function values = '//num2str(nf)//spaces//'Least value of F = '//num2str(f) +end if + +if (is_constrained .and. present(constr)) then + if (size(constr) <= 2) then + constr_message = newline//'The constraint value is: '//num2str(constr) ! Printed in one line + else + constr_message = newline//'The constraint value is:'//newline//num2str(constr) + end if +else + constr_message = '' +end if + +! Print the message. +if (abs(iprint) >= 2) then + message = newline//ret_message//nf_message//x_message//constr_message//newline +else + message = ret_message//nf_message//x_message//constr_message//newline +end if +if (len(fname) > 0) then + call fprint(message, fname=fname, faction='append') +else + call fprint(message, funit=funit, faction='append') +end if + +!====================! +! Calculation ends ! +!====================! +end subroutine retmsg + + +subroutine rhomsg(solver, iprint, nf, delta, f, rho, x, cstrv, constr, cpen) +!--------------------------------------------------------------------------------------------------! +! This subroutine prints messages when RHO is updated. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, STDOUT +use, non_intrinsic :: fprint_mod, only : fprint +use, non_intrinsic :: linalg_mod, only : maximum +use, non_intrinsic :: string_mod, only : strip, num2str +implicit none + +! Compulsory inputs +character(len=*), intent(in) :: solver +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: nf +real(RP), intent(in) :: delta +real(RP), intent(in) :: f +real(RP), intent(in) :: rho +real(RP), intent(in) :: x(:) + +! Optional inputs +real(RP), intent(in), optional :: cstrv +real(RP), intent(in), optional :: constr(:) +real(RP), intent(in), optional :: cpen + +! Local variables +character(len=*), parameter :: newline = new_line('') +character(len=:), allocatable :: constr_message +character(len=:), allocatable :: fname +character(len=:), allocatable :: message +character(len=:), allocatable :: nf_message +character(len=:), allocatable :: rho_message +character(len=:), allocatable :: x_message +integer :: funit ! Logical unit for the writing. Should be an integer of default kind. +logical :: is_constrained +real(RP) :: cstrv_loc + +!====================! +! Calculation starts ! +!====================! + +if (abs(iprint) < 2) then ! No printing + return +elseif (iprint > 0) then ! Print the message to the standard out. + funit = STDOUT + fname = '' +else ! Print the message to a file named FNAME. + fname = strip(solver)//'_output.txt' +end if + +! Decide whether the problem is truly constrained. +if (present(constr)) then + is_constrained = (size(constr) > 0) +else + is_constrained = present(cstrv) +end if + +! Decide the constraint violation. +if (present(cstrv)) then + cstrv_loc = cstrv +elseif (present(constr)) then + cstrv_loc = maximum([ZERO, -constr]) ! N.B.: We assume that the constraint is CONSTR >= 0. +else + cstrv_loc = ZERO +end if + +if (present(cpen)) then + rho_message = newline//'New RHO = '//num2str(rho)//spaces//'Delta = '//num2str(delta)//spaces// & + & 'CPEN = '//num2str(cpen) +else + rho_message = newline//'New RHO = '//num2str(rho)//spaces//'Delta = '//num2str(delta) +end if + +if (size(x) <= 2) then + x_message = newline//'The corresponding X is: '//num2str(x) ! Printed in one line +else + x_message = newline//'The corresponding X is:'//newline//num2str(x) +end if + +if (is_constrained) then + nf_message = newline//'Number of function values = '//num2str(nf)//spaces// & + & 'Least value of F = '//num2str(f)//spaces//'Constraint violation = '//num2str(cstrv_loc) +else + nf_message = newline//'Number of function values = '//num2str(nf)//spaces//'Least value of F = '//num2str(f) +end if + +if (is_constrained .and. present(constr)) then + if (size(constr) <= 2) then + constr_message = newline//'The constraint value is: '//num2str(constr) ! Printed in one line + else + constr_message = newline//'The constraint value is:'//newline//num2str(constr) + end if +else + constr_message = '' +end if + +! Print the message. +if (abs(iprint) >= 3) then + message = newline//rho_message//nf_message//x_message//constr_message +else + message = rho_message//nf_message//x_message//constr_message +end if +if (len(fname) > 0) then + call fprint(message, fname=fname, faction='append') +else + call fprint(message, funit=funit, faction='append') +end if + +!====================! +! Calculation ends ! +!====================! +end subroutine rhomsg + + +subroutine cpenmsg(solver, iprint, cpen) +!--------------------------------------------------------------------------------------------------! +! This subroutine prints a message when CPEN is updated. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, STDOUT +use, non_intrinsic :: fprint_mod, only : fprint +use, non_intrinsic :: string_mod, only : strip, num2str +implicit none + +! Compulsory inputs +character(len=*), intent(in) :: solver +integer(IK), intent(in) :: iprint + +! Optional inputs +real(RP), intent(in), optional :: cpen + +! Local variables +character(len=*), parameter :: newline = new_line('') +character(len=:), allocatable :: fname +character(len=:), allocatable :: message +integer :: funit ! Logical unit for the writing. Should be an integer of default kind. + +!====================! +! Calculation starts ! +!====================! + +if (abs(iprint) < 2) then ! No printing + return +elseif (iprint > 0) then ! Print the message to the standard out. + funit = STDOUT + fname = '' +else ! Print the message to a file named FNAME. + fname = strip(solver)//'_output.txt' +end if + +! Print the message. +if (abs(iprint) >= 3) then + message = newline//'Set CPEN to '//num2str(cpen) +else + message = newline//newline//'Set CPEN to '//num2str(cpen) +end if +if (len(fname) > 0) then + call fprint(message, fname=fname, faction='append') +else + call fprint(message, funit=funit, faction='append') +end if + +!====================! +! Calculation ends ! +!====================! +end subroutine cpenmsg + + +subroutine fmsg(solver, state, iprint, nf, delta, f, x, cstrv, constr) +!--------------------------------------------------------------------------------------------------! +! This subroutine prints messages for each evaluation of the objective function. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, STDOUT +use, non_intrinsic :: fprint_mod, only : fprint +use, non_intrinsic :: linalg_mod, only : maximum +use, non_intrinsic :: string_mod, only : strip, num2str +implicit none + +! Compulsory inputs +character(len=*), intent(in) :: solver +! `state` is a string indicating the solver's state when the function evaluation is invoked. Its +! value can be 'Initialization', 'Trust region', 'Geometry', or 'Rescue'. +character(len=*), intent(in) :: state +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: nf +real(RP), intent(in) :: delta +real(RP), intent(in) :: f +real(RP), intent(in) :: x(:) + +! Optional inputs +real(RP), intent(in), optional :: cstrv +real(RP), intent(in), optional :: constr(:) + +! Local variables +character(len=*), parameter :: newline = new_line('') +character(len=:), allocatable :: constr_message +character(len=:), allocatable :: delta_message +character(len=:), allocatable :: fname +character(len=:), allocatable :: message +character(len=:), allocatable :: nf_message +character(len=:), allocatable :: x_message +integer :: funit ! Logical unit for the writing. Should be an integer of default kind. +logical :: is_constrained +real(RP) :: cstrv_loc + +!====================! +! Calculation starts ! +!====================! + +if (abs(iprint) < 3) then ! No printing + return +elseif (iprint > 0) then ! Print the message to the standard out. + funit = STDOUT + fname = '' +else ! Print the message to a file named FNAME. + fname = strip(solver)//'_output.txt' +end if + +! Decide whether the problem is truly constrained. +if (present(constr)) then + is_constrained = (size(constr) > 0) +else + is_constrained = present(cstrv) +end if + +! Decide the constraint violation. +if (present(cstrv)) then + cstrv_loc = cstrv +elseif (present(constr)) then + cstrv_loc = maximum([ZERO, -constr]) ! N.B.: We assume that the constraint is CONSTR >= 0. +else + cstrv_loc = ZERO +end if + +delta_message = newline//state//' step with radius = '//num2str(delta) + +if (is_constrained) then + nf_message = newline//'Function number '//num2str(nf)//spaces//'F = '//num2str(f)// & + & spaces//'Constraint violation = '//num2str(cstrv_loc) +else + nf_message = newline//'Function number '//num2str(nf)//spaces//'F = '//num2str(f) +end if + +if (size(x) <= 2) then + x_message = newline//'The corresponding X is: '//num2str(x) ! Printed in one line +else + x_message = newline//'The corresponding X is:'//newline//num2str(x) +end if + +if (is_constrained .and. present(constr)) then + if (size(constr) <= 2) then + constr_message = newline//'The constraint value is: '//num2str(constr) ! Printed in one line + else + constr_message = newline//'The constraint value is:'//newline//num2str(constr) + end if +else + constr_message = '' +end if + +! Print the message. +message = delta_message//nf_message//x_message//constr_message +if (len(fname) > 0) then + call fprint(message, fname=fname, faction='append') +else + call fprint(message, funit=funit, faction='append') +end if + +!====================! +! Calculation ends ! +!====================! +end subroutine fmsg + + +end module message_mod diff --git a/examples/fortran/prima/native/common/pintrf.f90 b/examples/fortran/prima/native/common/pintrf.f90 new file mode 100644 index 000000000..a95b446ad --- /dev/null +++ b/examples/fortran/prima/native/common/pintrf.f90 @@ -0,0 +1,56 @@ +module pintrf_mod +!--------------------------------------------------------------------------------------------------! +! This is a module specifying the abstract interfaces OBJ, OBJCON, and CALLBACK. OBJ evaluates the +! objective function for unconstrained, bound constrained, and linearly constrained problems; OBJCON +! evaluates the objective and constraint functions for nonlinearly constrained problems; CALLBACK +! is a callback function that is called after each iteration of the solvers to report the progress +! and optionally request termination. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020. +! +! Last Modified: Friday, December 22, 2023 PM01:23:44 +!--------------------------------------------------------------------------------------------------! + +!!!!!! Users must provide the implementation of OBJ or OBJCON. !!!!!! + +implicit none +private +public :: OBJ, OBJCON, CALLBACK + + +abstract interface + + subroutine OBJ(x, f) + use consts_mod, only : RP + implicit none + real(RP), intent(in) :: x(:) + real(RP), intent(out) :: f + end subroutine OBJ + + + subroutine OBJCON(x, f, constr) + use consts_mod, only : RP + implicit none + real(RP), intent(in) :: x(:) + real(RP), intent(out) :: f + real(RP), intent(out) :: constr(:) + end subroutine OBJCON + + + subroutine CALLBACK(x, f, nf, tr, cstrv, nlconstr, terminate) + use consts_mod, only : RP, IK + implicit none + real(RP), intent(in) :: x(:) + real(RP), intent(in) :: f + integer(IK), intent(in) :: nf + integer(IK), intent(in) :: tr + real(RP), intent(in), optional :: cstrv + real(RP), intent(in), optional :: nlconstr(:) + logical, intent(out), optional :: terminate + end subroutine CALLBACK + +end interface + +end module pintrf_mod diff --git a/examples/fortran/prima/native/common/powalg.f90 b/examples/fortran/prima/native/common/powalg.f90 new file mode 100644 index 000000000..646b2ffbd --- /dev/null +++ b/examples/fortran/prima/native/common/powalg.f90 @@ -0,0 +1,1940 @@ +module powalg_mod +!--------------------------------------------------------------------------------------------------! +! This module provides some Powell-style linear algebra procedures. +! +! TODO: +! Divide the module into three submodules: +! - QR: procedures concerning QR factorization +! - QUADRATIC: procedures concerning quadratic polynomials represented by [GQ, PQ, HQ] so that +! Q(Y) = + 0.5*, +! HESSIAN consists of an explicit part HQ and an implicit part PQ in Powell's way: +! HESSIAN = HQ + sum_K=1^NPT PQ(K)*(XPT(:, K)*XPT(:, K)^T) . +! - LAGINT: procedures concerning quadratic LAGrange INTerpolation. +! +! Zaikun (20230321): In a test on 20230321 on problems of at most 200 variables, it affects (not +! necessarily worsens) the performance of NEWUOA/LINCOA quite marginally if the update of IDZ is +! completely disabled (and hence IDZ remains one forever). Therefore, in the first implementation of +! an algorithm based on the derivative-free PSB, it seems same to ignore IDZ. It is similar for the +! RESCUE technique of BOBYQA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: July 2020 +! +! Last Modified: Thu 14 Aug 2025 07:36:04 AM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private + +!--------------------------------------------------------------------------------------------------! +! QR: +public :: qradd, qrexc +!--------------------------------------------------------------------------------------------------! +! QUADRATIC: +public :: quadinc, errquad +public :: hess_mul +!--------------------------------------------------------------------------------------------------! +! LAGINT (quadratic LAGrange INTerpolation): +public :: omega_col, omega_mul, omega_inprod +public :: updateh, errh +public :: calvlag, calbeta, calden +public :: setij +!--------------------------------------------------------------------------------------------------! + +interface qradd + module procedure qradd_Rdiag, qradd_Rfull +end interface + +interface qrexc + module procedure qrexc_Rdiag, qrexc_Rfull +end interface + +interface quadinc + module procedure quadinc_d0, quadinc_ghv +end interface quadinc + +interface calvlag + module procedure calvlag_lfqint, calvlag_qint +end interface calvlag + + +contains + + +subroutine qradd_Rdiag(c, Q, Rdiag, n) ! Used in COBYLA +!--------------------------------------------------------------------------------------------------! +! This subroutine updates the QR factorization of an MxN matrix A of full column rank, attempting to +! add a new column C is to this matrix as the LAST column while maintaining the full-rankness. +! Case 1. If C is not in range(A) (theoretically, it implies N < M), then the new matrix is [A, C]; +! Case 2. If C is in range(A), then the new matrix is [A(:, 1:N-1), C]. +! Zaikun 2023903: It may happen in the second case that C is in the range of A(:, 1:N-1), and the +! new matrix does not have full column rank any more. Indeed, Powell wrote in comments that "set +! IOUT to the index of the constraint (here, column of A --- Zaikun) to be deleted, but branch if no +! suitable index can be found". The idea is to replace a column of A by C so that the new matrix +! still has full rank (such a column must exist unless C = 0). But his code sets IOUT = N always. +! Maybe he found this worked well enough in practice. Meanwhile, Powell's code includes a snippet +! that can never be reached, which was probably intended to deal with the case with IOUT =/= N. +! N.B.: +! 0. Instead of R, this subroutine updates RDIAG, which is diag(R), with a size at most M and at +! least MIN(M, N+1). The number is MIN(M, N+1) rather than MIN(M, N) as N may be augmented by 1 in +! the subroutine. +! 1. With the two cases specified as above, this function does not need A as an input. +! 2. The subroutine changes only Q(:, NSAVE+1:M) (NSAVE is the original value of N) +! and R(:, N) (N takes the updated value). +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : matprod, inprod, norm, planerot, hypotenuse, isorth, isminor, trueloc +implicit none + +! Inputs +real(RP), intent(in) :: c(:) ! C(M) + +! In-outputs +integer(IK), intent(inout) :: n +real(RP), intent(inout) :: Q(:, :) ! Q(M, M) +real(RP), intent(inout) :: Rdiag(:) ! MIN(M, N+1) <= SIZE(Rdiag) <= M + +! Local variables +character(len=*), parameter :: srname = 'QRADD_RDIAG' +integer(IK) :: k +integer(IK) :: m +integer(IK) :: nsave +real(RP) :: cq(size(Q, 2)) +real(RP) :: cqa(size(Q, 2)) +real(RP) :: G(2, 2) +!------------------------------------------------------------! +real(RP) :: Qsave(size(Q, 1), n) ! Debugging only +real(RP) :: Rdsave(n) ! Debugging only +real(RP) :: tol ! Debugging only +!------------------------------------------------------------! + +! Sizes +m = int(size(Q, 2), kind(m)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 0 .and. n <= m, '0 <= N <= M', srname) ! N = 0 is possible. + call assert(size(c) == m, 'SIZE(C) == M', srname) + call assert(size(Rdiag) >= min(m, n + 1_IK) .and. size(Rdiag) <= m, 'MIN(M, N+1) <= SIZE(Rdiag) <= M', srname) + call assert(size(Q, 1) == m .and. size(Q, 2) == m, 'SIZE(Q) == [M, M]', srname) + tol = max(TEN**max(-8, -MAXPOW10), min(1.0E-1_RP, TEN**min(12, MAXPOW10) * EPS * real(m + 1_IK, RP))) + call assert(isorth(Q, tol), 'The columns of Q are orthonormal', srname) ! Costly! + Qsave = Q(:, 1:n) ! For debugging only + Rdsave = Rdiag(1:n) ! For debugging only +end if + +!====================! +! Calculation starts ! +!====================! + +nsave = n ! Needed for debugging (only). + +! As in Powell's COBYLA, CQ is set to 0 at the positions with CQ being negligible as per ISMINOR. +! This may not be the best choice if the subroutine is used in other contexts, e.g., LINCOA. +cq = matprod(c, Q) +cqa = matprod(abs(c), abs(Q)) +cq(trueloc(isminor(cq, cqa))) = ZERO !!MATLAB: cq(isminor(cq, cqa)) = zero + +! Update Q so that the columns of Q(:, N+2:M) are orthogonal to C. This is done by applying a 2D +! Givens rotation to Q(:, [K, K+1]) from the right to zero C'*Q(:, K+1) out for K = N+1, ..., M-1 +! in the reverse order. Nothing will be done if N >= M-1. +do k = m - 1_IK, n + 1_IK, -1 + if (abs(cq(k + 1)) > 0) then + ! Powell wrote CQ(K+1) /= 0 instead of ABS(CQ(K+1)) > 0. The two differ if CQ(K+1) is NaN. + ! If we apply the rotation below when CQ(K+1) = 0, then CQ(K) will get updated to |CQ(K)|. + G = planerot(cq([k, k + 1_IK])) + Q(:, [k, k + 1_IK]) = matprod(Q(:, [k, k + 1_IK]), transpose(G)) + cq(k) = hypotenuse(cq(k), cq(k + 1)) !cq(k) = sqrt(cq(k)**2 + cq(k + 1)**2) + end if +end do + +! Augment N by 1 if C is not in range(A). +! The two IFs cannot be merged as Fortran may evaluate CQ(N+1) even if N>=M, leading to a SEGFAULT. +if (n < m) then + ! Powell's condition for the following IF: CQ(N+1) /= 0. + if (abs(cq(n + 1)) > EPS**2 .and. .not. isminor(cq(n + 1), cqa(n + 1))) then + n = n + 1_IK + end if +end if + +! Update RDIAG so that RDIAG(N) = CQ(N) = INPROD(C, Q(:, N)). Note that N may have been augmented. +! Zaikun 20230903: Different from QRADD_RFULL, Powell did not maintain the positiveness of RDIAG. +if (n >= 1 .and. n <= m) then ! Indeed, N > M should not happen unless the input is wrong. + Rdiag(n) = cq(n) ! Indeed, RDIAG(N) = INPROD(C, Q(:, N)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(n >= nsave .and. n <= min(nsave + 1_IK, m), 'NSAV <= N <= MIN(NSAV + 1, M)', srname) + call assert(size(Rdiag) >= n .and. size(Rdiag) <= m, 'N <= SIZE(Rdiag) <= M', srname) + call assert(size(Q, 1) == m .and. size(Q, 2) == m, 'SIZE(Q) == [M, M]', srname) + call assert(isorth(Q, tol), 'The columns of Q are orthonormal', srname) ! Costly! + + call assert(all(abs(Q(:, 1:nsave) - Qsave(:, 1:nsave)) <= 0), 'Q(:, 1:NSAVE) is unchanged', srname) + call assert(all(abs(Rdiag(1:n - 1) - Rdsave(1:n - 1)) <= 0), 'Rdiag(1:N-1) is unchanged', srname) + + if (n < m .and. is_finite(norm(c))) then + call assert(norm(matprod(c, Q(:, n + 1:m))) <= max(tol, tol * norm(c)), 'C^T*Q(:, N+1:M) == 0', srname) + end if + if (n >= 1) then ! N = 0 is possible. + call assert(abs(inprod(c, Q(:, n)) - Rdiag(n)) <= max(tol, tol * inprod(abs(c), abs(Q(:, n)))) & + & .or. .not. is_finite(Rdiag(n)), 'C^T*Q(:, N) == Rdiag(N)', srname) + end if +end if +end subroutine qradd_Rdiag + + +subroutine qradd_Rfull(c, Q, R, n) ! Used in LINCOA +!--------------------------------------------------------------------------------------------------! +! This subroutine updates the QR factorization of an MxN matrix A = Q*R(:, 1:N) when a new column C +! is appended to this matrix A as the LAST column. +! N.B.: +! 0. Different from QRADD_RDIAG, QRADD_RFULL always append C to A, and always increase N by 1. This +! is because it is for sure that C is not in the column space of A in LINCOA. +! 1. At entry, Q is a MxM orthonormal matrix, and R is a MxL upper triangular matrix with N < L <= M. +! 2. The subroutine changes only Q(:, N+1:M) and R(:, N+1) with N taking the original value. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : matprod, planerot, isorth, istriu, diag +implicit none + +! Inputs +real(RP), intent(in) :: c(:) ! C(M) + +! In-outputs +integer(IK), intent(inout) :: n +real(RP), intent(inout) :: Q(:, :) ! Q(M, M) +real(RP), intent(inout) :: R(:, :) ! R(M, :), N+1 <= SIZE(R, 2) <= M + +! Local variables +character(len=*), parameter :: srname = 'QRADD_RFULL' +integer(IK) :: k +integer(IK) :: m +real(RP) :: cq(size(Q, 2)) +real(RP) :: G(2, 2) +!------------------------------------------------------------! +real(RP) :: Anew(size(Q, 1), n + 1) ! Debugging only +real(RP) :: Qsave(size(Q, 1), n) ! Debugging only +real(RP) :: Rsave(size(R, 1), n) ! Debugging only +real(RP) :: tol ! Debugging only +!------------------------------------------------------------! + +! Sizes +m = int(size(Q, 1), kind(m)) + +if (DEBUGGING) then + call assert(n >= 0 .and. n <= m - 1, '0 <= N <= M - 1', srname) + call assert(size(c) == m, 'SIZE(C) == M', srname) + call assert(size(Q, 1) == m .and. size(Q, 2) == m, 'SIZE(Q) = [M, M]', srname) + call assert(size(Q, 2) == size(R, 1), 'SIZE(Q, 2) == SIZE(R, 1)', srname) + call assert(size(R, 2) >= n + 1 .and. size(R, 2) <= m, 'N+1 <= SIZE(R, 2) <= M', srname) + tol = max(TEN**max(-8, -MAXPOW10), min(1.0E-1_RP, TEN**min(8, MAXPOW10) * EPS * real(m + 1_IK, RP))) + call assert(isorth(Q, tol), 'The columns of Q are orthogonal', srname) + call assert(istriu(R), 'R is upper triangular', srname) + call assert(all(diag(R(:, 1:n)) > 0), 'DIAG(R(:, 1:N)) > 0', srname) + Anew = reshape([matprod(Q, R(:, 1:n)), c], shape(Anew)) + Qsave = Q(:, 1:n) ! For debugging only. + Rsave = R(:, 1:n) ! For debugging only. +end if + +cq = matprod(c, Q) + +! Update Q so that the columns of Q(:, N+2:M) are orthogonal to C. This is done by applying a 2D +! Givens rotation to Q(:, [K, K+1]) from the right to zero C'*Q(:, K+1) out for K = N+1, ..., M-1. +! Nothing will be done if N >= M-1. +do k = m - 1_IK, n + 1_IK, -1 + if (abs(cq(k + 1)) > 0) then ! Powell: IF (ABS(CQ(K + 1)) > 1.0D-20 * ABS(CQ(K))) THEN + G = planerot(cq([k, k + 1_IK])) + Q(:, [k, k + 1_IK]) = matprod(Q(:, [k, k + 1_IK]), transpose(G)) + cq(k) = sqrt(cq(k)**2 + cq(k + 1)**2) + end if +end do + +R(1:n, n + 1) = matprod(c, Q(:, 1:n)) + +! Maintain the positiveness of the diagonal entries of R. +if (cq(n + 1) < 0) then + Q(:, n + 1) = -Q(:, n + 1) +end if +R(n + 1, n + 1) = abs(cq(n + 1)) + +n = n + 1_IK + +if (DEBUGGING) then + call assert(n >= 1 .and. n <= m, '1 <= N <= M', srname) + call assert(size(Q, 1) == m .and. size(Q, 2) == m, 'SIZE(Q) = [M, M]', srname) + call assert(size(Q, 2) == size(R, 1), 'SIZE(Q, 2) == SIZE(R, 1)', srname) + call assert(size(R, 2) >= n .and. size(R, 2) <= m, 'N <= SIZE(R, 2) <= M', srname) + call assert(isorth(Q, tol), 'The columns of Q are orthogonal', srname) + call assert(istriu(R), 'R is upper triangular', srname) + call assert(all(diag(R(:, 1:n)) > 0), 'DIAG(R(:, 1:N)) > 0', srname) + + ! !call assert(.not. any(abs(Q(:, 1:n - 1) - Qsave(:, 1:n - 1)) > 0), 'Q(:, 1:N-1) is unchanged', srname) + ! !call assert(.not. any(abs(R(:, 1:n - 1) - Rsave(:, 1:n - 1)) > 0), 'R(:, 1:N-1) is unchanged', srname) + ! If we can ensure that Q and R do not contain NaN or Inf, use the following lines instead of the last two. + call assert(all(abs(Q(:, 1:n - 1) - Qsave(:, 1:n - 1)) <= 0), 'Q(:, 1:N-1) is unchanged', srname) + call assert(all(abs(R(:, 1:n - 1) - Rsave(:, 1:n - 1)) <= 0), 'R(:, 1:N-1) is unchanged', srname) + + ! The following test may fail. + call assert(all(abs(Anew - matprod(Q, R(:, 1:n))) <= max(tol, tol * maxval(abs(Anew)))), 'Anew = Q*R', srname) +end if +end subroutine qradd_Rfull + + +subroutine qrexc_Rdiag(A, Q, Rdiag, i) ! Used in COBYLA +!--------------------------------------------------------------------------------------------------! +! This subroutine updates the QR factorization for an MxN matrix A = Q*R so that the updated Q and +! R form a QR factorization of [A_1, ..., A_{I-1}, A_{I+1}, ..., A_N, A_I], which is the matrix +! obtained by rearranging columns [I, I+1, ..., N] of A to [I+1, ..., N, I]. Here, Q is a matrix +! whose columns are orthogonal, and R, which is not present, is an upper triangular matrix whose +! diagonal entries are nonzero. Q and R need not to be square. +! N.B.: +! 0. Instead of R, this subroutine updates RDIAG, which is diag(R), the size being N. +! 1. With L = SIZE(Q, 2) = SIZE(R, 1), we have M >= L >= N. Most often, L = M or N. +! 2. The subroutine changes only Q(:, I:N) and RDIAG(I:N). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : matprod, inprod, norm, planerot, isorth, istriu, diag +implicit none + +! Inputs +real(RP), intent(in) :: A(:, :) ! A(M, N) + +! In-outputs +real(RP), intent(inout) :: Q(:, :) ! Q(M, :), N <= SIZE(Q, 2) <= M +real(RP), intent(inout) :: Rdiag(:) ! Rdiag(N) +integer(IK), intent(in) :: i + +! Local variables +character(len=*), parameter :: srname = 'QREXC_RDIAG' +integer(IK) :: k +integer(IK) :: m +integer(IK) :: n +real(RP) :: G(2, 2) +!------------------------------------------------------------! +real(RP) :: Anew(size(A, 1), size(A, 2)) ! Debugging only +real(RP) :: Qsave(size(Q, 1), size(Q, 2)) ! Debugging only +real(RP) :: QtAnew(size(Q, 2), size(A, 2)) ! Debugging only +real(RP) :: Rdsave(i) ! Debugging only +real(RP) :: tol ! Debugging only +!------------------------------------------------------------! + +! Sizes +m = int(size(A, 1), kind(m)) +n = int(size(A, 2), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. n <= m, '1 <= N <= M', srname) + call assert(i >= 1 .and. i <= n, '1 <= i <= N', srname) + call assert(size(Rdiag) == n, 'SIZE(Rdiag) == N', srname) + call assert(size(Q, 1) == m .and. size(Q, 2) >= n .and. size(Q, 2) <= m, & + & 'SIZE(Q, 1) == M, N <= SIZE(Q, 2) <= M', srname) + tol = max(TEN**max(-8, -MAXPOW10), min(1.0E-1_RP, TEN**min(8, MAXPOW10) * EPS * real(m + 1_IK, RP))) + call assert(isorth(Q, tol), 'The columns of Q are orthonormal', srname) ! Costly! + Qsave = Q ! For debugging only. + Rdsave = Rdiag(1:i) ! For debugging only. +end if + +!====================! +! Calculation starts ! +!====================! + +if (i <= 0 .or. i >= n) then + ! Only I == N is really needed, as 1 <= I <= N unless the input is wrong. + return +end if + +! Let R be the upper triangular matrix in the QR factorization, namely R = Q^T*A. +! For each K, find the Givens rotation G with G*R([K, K+1], :) = [HYPT, 0], and update Q(:, [K,K+1]) +! to Q(:, [K, K+1])*G^T. Then R = Q^T*A is an upper triangular matrix as long as A(:, [K, K+1]) is +! updated to A(:, [K+1, K]). Indeed, this new upper triangular matrix can be obtained by first +! updating R([K, K+1], :) to G*R([K, K+1], :) and then exchanging its columns K and K+1; at the same +! time, entries K and K+1 of R's diagonal RDIAG become [HYPT, -(RDIAG(K+1) / HYPT) * RDIAG(K)]. +! After this is done for each K = 1, ..., N-1, we obtain the QR factorization of the matrix that +! rearranges columns [I, I+1, ..., N] of A as [I+1, ..., N, I]. +! Powell's code, however, is slightly different: before everything, he first exchanged columns K and +! K+1 of Q (as well as rows K and K+1 of R). This makes sure that the entires of the update RDIAG +! are all positive if it is the case for the original RDIAG. +! Zaikun 20230903: It turns out that Powell's code does not ensure that the original RDIAG is +! positive (see QRADD_RDIAG), and hence the updated RDIAG may contain negative values. +do k = i, n - 1_IK + G = planerot([Rdiag(k + 1), inprod(Q(:, k), A(:, k + 1))]) + Q(:, [k, k + 1_IK]) = matprod(Q(:, [k + 1_IK, k]), transpose(G)) + ! Powell's code updates RDIAG in the following way: + ! !HYPT = SQRT(RDIAG(K + 1)**2 + INPROD(Q(:, K), A(:, K + 1))**2) + ! !RDIAG([K, K + 1_IK]) = [HYPT, (RDIAG(K + 1) / HYPT) * RDIAG(K)] + ! Note that RDIAG(N) inherits all rounding in RDIAG(I:N-1) and Q(:, I:N-1) and hence contain + ! significant errors. Thus we may modify Powell's code to set only RDIAG(K) = HYPT here and then + ! calculate RDIAG(N) by an inner product after the loop. Nevertheless, we simply calculate RDIAG + ! from scratch we do below. +end do + +! Calculate RDIAG(I:N) from scratch. +Rdiag(i:n - 1) = [(inprod(Q(:, k), A(:, k + 1)), k=i, n - 1_IK)] +!!MATLAB: Rdiag(i:n-1) = sum(Q(:, i:n-1) .* A(:, i+1:n), 1); % Row vector +Rdiag(n) = inprod(Q(:, n), A(:, i)) ! Calculate RDIAG(N) from scratch. See the comments above. + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(Rdiag) == n, 'SIZE(Rdiag) == N', srname) + call assert(size(Q, 1) == m .and. size(Q, 2) >= n .and. size(Q, 2) <= m, & + & 'SIZE(Q, 1) == M, N <= SIZE(Q, 2) <= M', srname) + call assert(isorth(Q, tol), 'The columns of Q are orthonormal', srname) ! Costly! + + Qsave(:, i:n) = Q(:, i:n) + call assert(all(abs(Q - Qsave) <= 0), 'Q is unchanged except Q(:, I:N)', srname) + call assert(all(abs(Rdiag(1:i - 1) - Rdsave(1:i - 1)) <= 0), 'Rdiag(1:I-1) is unchanged', srname) + + Anew = reshape([A(:, 1:i - 1), A(:, i + 1:n), A(:, i)], shape(Anew)) + QtAnew = matprod(transpose(Q), Anew) + call assert(istriu(QtAnew, tol), 'Q^T*Anew is upper triangular', srname) + ! The following test may fail if RDIAG is not calculated from scratch. + call assert(norm(diag(QtAnew) - Rdiag) <= max(tol, tol * norm([(inprod(abs(Q(:, k)), & + & abs(Anew(:, k))), k=1, n)])), 'Rdiag == diag(Q^T*Anew)', srname) + !!MATLAB: norm(diag(QtAnew) - Rdiag) <= max(tol, tol * norm(sum(abs(Q(:, 1:n)) .* abs(Anew), 1))) +end if +end subroutine qrexc_Rdiag + + +subroutine qrexc_Rfull(Q, R, i) ! Used in LINCOA +!--------------------------------------------------------------------------------------------------! +! This subroutine updates the QR factorization for an MxN matrix A = Q*R so that the updated Q and +! R form a QR factorization of [A_1, ..., A_{I-1}, A_{I+1}, ..., A_N, A_I], which is the matrix +! obtained by rearranging columns [I, I+1, ..., N] of A to [I+1, ..., N, I]. At entry, A = Q*R, +! Q is a matrix whose columns are orthogonal, and R is an upper triangular matrix whose diagonal +! entries are all nonzero. Q and R need not to be square. +! N.B.: +! 1. With L = SIZE(Q, 2) = SIZE(R, 1), we have M >= L >= N. Most often, L = M or N. +! 2. The subroutine changes only Q(:, I:N) and R(:, I:N). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : matprod, planerot, isorth, istriu, hypotenuse, diag +implicit none + +! Inputs +integer(IK), intent(in) :: i + +! In-outputs +real(RP), intent(inout) :: Q(:, :) ! Q(M, :), SIZE(Q, 2) <= M +real(RP), intent(inout) :: R(:, :) ! R(:, N), SIZE(R, 1) >= N + +! Local variables +character(len=*), parameter :: srname = 'QREXC_RFULL' +integer(IK) :: k +integer(IK) :: m +integer(IK) :: n +real(RP) :: G(2, 2) +real(RP) :: hypt +!------------------------------------------------------------! +real(RP) :: Anew(size(Q, 1), size(R, 2)) ! Debugging only +real(RP) :: Qsave(size(Q, 1), size(Q, 2)) ! Debugging only +real(RP) :: Rsave(size(R, 1), i) ! Debugging only +real(RP) :: tol ! Debugging only +!------------------------------------------------------------! + +! Sizes +m = int(size(Q, 1), kind(m)) +n = int(size(R, 2), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. n <= m, '1 <= N <= M', srname) + call assert(i >= 1 .and. i <= n, '1 <= I <= N', srname) + call assert(size(Q, 2) == size(R, 1), 'SIZE(Q, 2) == SIZE(R, 1)', srname) + call assert(size(Q, 2) >= n .and. size(Q, 2) <= m, 'N <= SIZE(Q, 2) <= M', srname) + call assert(size(R, 1) >= n .and. size(R, 1) <= m, 'N <= SIZE(R, 1) <= M', srname) + tol = max(TEN**max(-8, -MAXPOW10), min(1.0E-1_RP, TEN**min(8, MAXPOW10) * EPS * real(m + 1_IK, RP))) + call assert(isorth(Q, tol), 'The columns of Q are orthogonal', srname) + call assert(istriu(R), 'R is upper triangular', srname) + call assert(all(diag(R(:, 1:n)) > 0), 'DIAG(R(:, 1:N)) > 0', srname) + Anew = matprod(Q, R) + Anew = reshape([Anew(:, 1:i - 1), Anew(:, i + 1:n), Anew(:, i)], shape(Anew)) + Qsave = Q ! For debugging only. + Rsave = R(:, 1:i) ! For debugging only. +end if + +!====================! +! Calculation starts ! +!====================! + +if (i <= 0 .or. i >= n) then + ! Only I == N is really needed, as 1 <= I <= N unless the input is wrong. + return +end if + +! For each K, find the Givens rotation G with G*R([K, K+1], K+1) = [HYPT, 0]. Then make two updates. +! First, update Q(:, [K, K+1]) to Q(:, [K, K+1])*G^T, and R([K, K+1], :) to G*R[K+1, K], :), which +! keeps Q*R unchanged and maintains the orthogonality of Q's columns. Second, exchange columns K and +! K+1 of R. Then R becomes upper triangular, and the new product Q*R exchanges columns K and K+1 of +! the original one. After this is done for each K = 1, ..., N-1, we obtain the QR factorization of +! the matrix that rearranges columns [I, I+1, ..., N] of A as [I+1, ..., N, I]. +! Powell's code, however, is slightly different: before everything, he first exchanged columns K and +! K+1 of Q as well as rows K and K+1 of R. This makes sure that the diagonal entries of the updated +! R are all positive if it is the case for the original R. +do k = i, n - 1_IK + G = planerot(R([k + 1_IK, k], k + 1)) + ! HYPT must be calculated before R is updated. + hypt = hypotenuse(R(k + 1, k + 1), R(k, k + 1)) !hypt = sqrt(R(k, k + 1)**2 + R(k + 1, k + 1)**2) + + ! Update Q(:, [K, K+1]). + Q(:, [k, k + 1_IK]) = matprod(Q(:, [k + 1_IK, k]), transpose(G)) + + ! Update R([K, K+1], :). + R([k, k + 1_IK], k:n) = matprod(G, R([k + 1_IK, k], k:n)) + R(1:k + 1, [k, k + 1_IK]) = R(1:k + 1, [k + 1_IK, k]) + ! N.B.: The above two lines implement the following while noting that R is upper triangular. + ! !R([K, K + 1_IK], :) = MATPROD(G, R([K + 1_IK, K], :)) ! No need for R([K, K+1], 1:K-1) = 0 + ! !R(:, [K, K + 1_IK]) = R(:, [K + 1_IK, K]) ! No need for R(K+2:, [K, K+1]) = 0 + + ! Revise R([K, K+1], K). Changes nothing in theory but seems good for the practical performance. + R([k, k + 1_IK], k) = [hypt, ZERO] + + !----------------------------------------------------------------------------------------------! + ! The following code performs the update without exchanging columns K and K+1 of Q or rows K and + ! K+1 of R beforehand. If the diagonal entries of the original R are positive, then all the + ! updated ones become negative. + ! + ! !G = planerot(R([k, k + 1_IK], k + 1)) + ! !hypt = hypotenuse(R(k + 1, k + 1), R(k, k + 1)) !hypt = sqrt(R(k, k + 1)**2 + R(k + 1, k + 1)**2) + ! ! + ! !Q(:, [k, k + 1_IK]) = matprod(Q(:, [k, k + 1_IK]), transpose(G)) + ! ! + ! !R([k, k + 1_IK], k:n) = matprod(G, R([k, k + 1_IK], k:n)) + ! !R(1:k + 1, [k, k + 1_IK]) = R(1:k + 1, [k + 1_IK, k]) + ! !R([k, k + 1_IK], k) = [hypt, ZERO] + !----------------------------------------------------------------------------------------------! +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(Q, 2) == size(R, 1), 'SIZE(Q, 2) == SIZE(R, 1)', srname) + call assert(size(Q, 2) >= n .and. size(Q, 2) <= m, 'N <= SIZE(Q, 2) <= M', srname) + call assert(size(R, 1) >= n .and. size(R, 1) <= m, 'N <= SIZE(R, 1) <= M', srname) + call assert(isorth(Q, tol), 'The columns of Q are orthogonal', srname) + call assert(istriu(R), 'R is upper triangular', srname) + call assert(all(diag(R(:, 1:n)) > 0), 'DIAG(R(:, 1:N)) > 0', srname) + + Qsave(:, i:n) = Q(:, i:n) + ! !call assert(.not. any(abs(Q - Qsave) > 0), 'Q is unchanged except Q(:, I:N)', srname) + ! !call assert(.not. any(abs(R(:, 1:i - 1) - Rsave(:, 1:i - 1)) > 0), 'R(:, 1:I-1) is unchanged', srname) + ! If we can ensure that Q and R do not contain NaN or Inf, use the following lines instead of the last two. + call assert(all(abs(Q - Qsave) <= 0), 'Q is unchanged except Q(:, I:N)', srname) + call assert(all(abs(R(:, 1:i - 1) - Rsave(:, 1:i - 1)) <= 0), 'R(:, 1:I-1) is unchanged', srname) + + ! The following test may fail. + call assert(all(abs(Anew - matprod(Q, R)) <= max(tol, tol * maxval(abs(Anew)))), 'Anew = Q*R', srname) +end if + +end subroutine qrexc_Rfull + + +function quadinc_d0(d, xpt, gq, pq, hq) result(qinc) +!--------------------------------------------------------------------------------------------------! +! This function evaluates QINC = Q(D) - Q(0) with Q being the quadratic function defined +! via [GQ, HQ, PQ] by +! Q(Y) = + 0.5*, +! where HESSIAN consists of an explicit part HQ and an implicit part PQ in Powell's way: +! HESSIAN = HQ + sum_K=1^NPT PQ(K)*(XPT(:, K)*XPT(:, K)^T) . +! N.B.: QUADINC_D0(D, XPT, GQ, PQ, HQ) = QUADINC_DX(D, ZEROS(SIZE(D)), XPT, GQ, PQ, HQ) +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : matprod, inprod, issymmetric +implicit none + +! Inputs +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: gq(:) ! GQ(N) +real(RP), intent(in) :: pq(:) ! PQ(NPT) +real(RP), intent(in), optional :: hq(:, :) ! HQ(N, N) + +! Output +real(RP) :: qinc + +! Local variable +character(len=*), parameter :: srname = 'QUADINC_D0' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: dxpt(size(pq)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(gq) == n, 'SIZE(GQ) = N', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) + if (present(hq)) then + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +!--------------------------------------------------------------------------------------------------! +! The following is Powell's scheme in LINCOA. +! !! First-order term and explicit second-order term +! !qinc = ZERO +! !do j = 1, n +! ! qinc = qinc + d(j) * gq(j) +! ! do i = 1, j +! ! t = d(i) * d(j) +! ! if (i == j) then +! ! t = HALF * t +! ! end if +! ! if (present(hq)) then +! ! qinc = qinc + t * hq(i, j) +! ! end if +! ! end do +! !end do +! ! +! !! Implicit second-order term +! !dxpt = matprod(d, xpt) +! !do i = 1, npt +! ! qinc = qinc + HALF * pq(i) * dxpt(i) * dxpt(i) ! In BOBYQA, it is QINC - HALF * PQ(I) * DXPT(I)**2. +! !end do +!--------------------------------------------------------------------------------------------------! + +!--------------------------------------------------------------------------------------------------! +! The following is a loop-free implementation, which should be applied in MATLAB/Python/R/Julia. +! N.B.: INPROD(DXPT, PQ * DXPT) = INPROD(D, HESS_MUL(D, XPT, PQ)) +!--------------------------------------------------------------------------------------------------! +dxpt = matprod(d, xpt) +if (present(hq)) then + qinc = inprod(d, gq + HALF * matprod(hq, d)) + HALF * inprod(dxpt, pq * dxpt) +else + qinc = inprod(d, gq) + HALF * inprod(dxpt, pq * dxpt) +end if +!!MATLAB: +!!if nargin >= 5 +!! qinc = d'*(gq + 0.5*hq*d) + 0.5*dxpt'*(pq*dxpt); +!!else +!! qinc = d'*gq + 0.5*dxpt'*(pq*dxpt); +!!end +!--------------------------------------------------------------------------------------------------! + +!====================! +! Calculation ends ! +!====================! + +end function quadinc_d0 + + +function quadinc_ghv(ghv, d, x) result(qinc) +!--------------------------------------------------------------------------------------------------! +! This function evaluates QINC = Q(X+D) - Q(X) with Q being the quadratic function defined via GHV by +! Q(Y) = + 0.5*, +! where GQ is GHV(1:N), and HESSIAN is the symmetric matrix whose upper triangular part is stored in +! GHV(N+1:N*(N+3)/2) column by column. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : inprod +implicit none +! Inputs +real(RP), intent(in) :: ghv(:) +real(RP), intent(in) :: d(:) +real(RP), intent(in) :: x(:) +! Outputs +real(RP) :: qinc +! Local variables +character(len=*), parameter :: srname = 'QUADINC_GHV' +integer(IK) :: ih +integer(IK) :: n +integer(IK) :: j +real(RP) :: s(size(x)) +real(RP) :: w(size(ghv)) + +! Sizes +n = int(size(x), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(d) == n, 'SIZE(D) = N', srname) + call assert(size(ghv) == n * (n + 3) / 2, 'SIZE(GHV) = N*(N+3)/2', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +s = x + d + +w(1:n) = d +do j = 1, n + ih = n + (j - 1_IK) * j / 2_IK + w(ih + 1:ih + j) = d(1:j) * s(j) + d(j) * x(1:j) + w(ih + j) = HALF * w(ih + j) +end do + +qinc = inprod(ghv, w) + +!====================! +! Calculation ends ! +!====================! + +end function quadinc_ghv + + +function errquad(fval, xpt, gq, pq, hq, kref) result(err) +!--------------------------------------------------------------------------------------------------! +! This function calculates the maximal relative error of Q in interpolating FVAL on XPT. +! Here, Q is the quadratic function defined via [GQ, HQ, PQ] by +! Q(Y) = + 0.5* if KREF is absent, +! Q(Y) = + 0.5* with XREF = XPT(:, KREF), if KREF is present. +! Here, HESSIAN consists of an explicit part HQ and an implicit part PQ in Powell's way: +! HESSIAN = HQ + sum_K=1^NPT PQ(K)*(XPT(:, K)*XPT(:, K)^T). +! N.B.: If KREF is absent, then GQ = nabla Q(0); otherwise, GQ = nabla Q(XREF). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan, is_posinf +use, non_intrinsic :: linalg_mod, only : issymmetric +implicit none + +! Inputs +real(RP), intent(in) :: fval(:) ! FVAL(NPT) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: gq(:) ! GQ(N) +real(RP), intent(in) :: pq(:) ! PQ(NPT) +real(RP), intent(in) :: hq(:, :) ! HQ(N, N) +integer(IK), intent(in), optional :: kref + +! Outputs +real(RP) :: err + +! Local variables +character(len=*), parameter :: srname = 'ERRQUAD' +integer(IK) :: k +integer(IK) :: n +integer(IK) :: npt +real(RP) :: fmq(size(xpt, 2)) +real(RP) :: qval(size(xpt, 2)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(size(fval) == npt, 'SIZE(FVAL) == NPT', srname) + call assert(.not. any(is_nan(fval) .or. is_posinf(fval)), 'FVAL is not NaN/+Inf', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(gq) == n, 'SIZE(GQ) == N', srname) + call assert(size(pq) == npt, 'SIZE(PQ) == NPT', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + if (present(kref)) then + call assert(kref >= 1 .and. kref <= npt, '1 <= KREF <= NPT', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +if (present(kref)) then + qval = [(quadinc(xpt(:, k) - xpt(:, kref), xpt, gq, pq, hq), k=1, npt)] +else + qval = [(quadinc(xpt(:, k), xpt, gq, pq, hq), k=1, npt)] +end if +!!MATLAB: +!!if nargin >= 5 +!! qval = cellfun(@(x) quadinc(x, xpt, gq, pq, hq), num2cell(xpt - xpt(:, kref), 1)); % Row vector +!! % xpt - xpt(:, kref): Implicit expansion +!!else +!! qval = cellfun(@(x) quadinc(x, xpt, gq, pq, hq), num2cell(xpt, 1)); % Row vector +!!end +if (.not. all(is_finite(qval))) then + err = REALMAX +else + fmq = fval - qval + err = (maxval(fmq) - minval(fmq)) / maxval([ONE, abs(fval)]) +end if + +!====================! +! Calculation ends ! +!====================! +! +end function errquad + + +function hess_mul(x, xpt, pq, hq) result(y) +!--------------------------------------------------------------------------------------------------! +! This function calculates HESSIAN*X, with HESSIAN consisting of an explicit part HQ (0 if absent) +! and an implicit part PQ in Powell's way: HESSIAN = HQ + sum_K=1^NPT PQ(K)*(XPT(:, K)*XPT(:, K)^T). +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : matprod, issymmetric +implicit none + +! Inputs +real(RP), intent(in) :: x(:) ! X(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: pq(:) ! PQ(NPT) +real(RP), intent(in), optional :: hq(:, :) ! HQ(N, N) + +! Outputs +real(RP) :: y(size(x)) + +! Local variables +character(len=*), parameter :: srname = 'HESS_MUL' +integer(IK) :: j +integer(IK) :: n +integer(IK) :: npt + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(size(x) == n, 'SIZE(Y) == N', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(pq) == npt, 'SIZE(PQ) == NPT', srname) + if (present(hq)) then + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +!--------------------------------------------------------------------------------! +!----------! y = matprod(hq, x) + matprod(xpt, pq * matprod(x, xpt)) !-----------! +!--------------------------------------------------------------------------------! +y = matprod(xpt, pq * matprod(x, xpt)) +if (present(hq)) then + do j = 1, n + y = y + hq(:, j) * x(j) + end do +end if + +!====================! +! Calculation ends ! +!====================! + +end function hess_mul + + +function omega_col(idz, zmat, k) result(y) +!--------------------------------------------------------------------------------------------------! +! This function calculates Y = column K of OMEGA. As Powell did in NEWUOA, BOBYQA, and LINCOA, +! OMEGA = sum_{i=1}^{K} S_i*ZMAT(:, i)*ZMAT(:, i)^T if S_i = -1 when i < IDZ and S_i = 1 if i >= IDZ +! OMEGA is the leading NPT-by-NPT block of the matrix H in (3.12) of the NEWUOA paper. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : matprod +implicit none + +! Inputs +integer(IK), intent(in) :: idz +integer(IK), intent(in) :: k +real(RP), intent(in) :: zmat(:, :) + +! Outputs +real(RP) :: y(size(zmat, 1)) + +! Local variables +character(len=*), parameter :: srname = 'OMEGA_COL' +real(RP) :: zk(size(zmat, 2)) + +! Preconditions +if (DEBUGGING) then + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(k >= 1 .and. idz <= size(zmat, 1), '1 <= K <= SIZE(ZMAT, 1)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +zk = zmat(k, :) +zk(1:idz - 1) = -zk(1:idz - 1) +y = matprod(zmat, zk) + +!====================! +! Calculation ends ! +!====================! + +end function omega_col + + +function omega_mul(idz, zmat, x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function calculates Y = OMEGA*X. As Powell did in NEWUOA, BOBYQA, and LINCOA, +! OMEGA = sum_{i=1}^{K} S_i*ZMAT(:, i)*ZMAT(:, i)^T if S_i = -1 when i < IDZ and S_i = 1 if i >= IDZ +! OMEGA is the leading NPT-by-NPT block of the matrix H in (3.12) of the NEWUOA paper. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : matprod +implicit none + +! Inputs +integer(IK), intent(in) :: idz +real(RP), intent(in) :: zmat(:, :) +real(RP), intent(in) :: x(:) + +! Outputs +real(RP) :: y(size(zmat, 1)) + +! Local variables +character(len=*), parameter :: srname = 'OMEGA_MUL' +real(RP) :: xz(size(zmat, 2)) + +! Preconditions +if (DEBUGGING) then + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(size(x) == size(zmat, 1), 'SIZE(X) == SIZE(ZMAT, 1)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +xz = matprod(x, zmat) +xz(1:idz - 1) = -xz(1:idz - 1) +y = matprod(zmat, xz) + +!====================! +! Calculation ends ! +!====================! + +end function omega_mul + + +function omega_inprod(idz, zmat, x, y) result(p) +!--------------------------------------------------------------------------------------------------! +! This function calculates P = X^T*OMEGA*Y. As Powell did in NEWUOA, BOBYQA, and LINCOA, +! OMEGA = sum_{i=1}^{K} S_i*ZMAT(:, i)*ZMAT(:, i)^T if S_i = -1 when i < IDZ and S_i = 1 if i >= IDZ +! OMEGA is the leading NPT-by-NPT block of the matrix H in (3.12) of the NEWUOA paper. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : matprod, inprod +implicit none + +! Inputs +integer(IK), intent(in) :: idz +real(RP), intent(in) :: zmat(:, :) +real(RP), intent(in) :: x(:) +real(RP), intent(in) :: y(:) + +! Outputs +real(RP) :: p + +! Local variables +character(len=*), parameter :: srname = 'OMEGA_INPROD' +real(RP) :: xz(size(zmat, 2)) +real(RP) :: yz(size(zmat, 2)) + +! Preconditions +if (DEBUGGING) then + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(size(x) == size(zmat, 1), 'SIZE(X) == SIZE(ZMAT, 1)', srname) + call assert(size(y) == size(zmat, 1), 'SIZE(Y) == SIZE(ZMAT, 1)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +xz = matprod(x, zmat) +xz(1:idz - 1) = -xz(1:idz - 1) +yz = matprod(y, zmat) +p = inprod(xz, yz) + +!====================! +! Calculation ends ! +!====================! + +end function omega_inprod + + +function errh(idz, bmat, zmat, xpt) result(err) +!--------------------------------------------------------------------------------------------------! +! This function calculates the error in H as the inverse of W. See (3.12) of the NEWUOA paper. +! N.B.: The (NPT+1)th column (row) of H is not contained in [BMAT, ZMAT]. It is [r; t(1); s] below. +! In the complete form, using MATLAB-style notation, the W and H in the NEWUOA paper are as follows. +! W = [A, ONES(NPT, 1), XPT^T; ONES(1, NPT), ZERO, ZEROS(1, N); XPT, ZEROS(N, 1), ZEROS(N, N)] +! H = [Omega, r, BMAT(:, 1:NPT)^T; r^T, t(1), s^T, BMAT(:, 1:NPT), s, BMAT(:, NPT+1:NPT+N)] +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : matprod, eye, issymmetric +implicit none + +! Inputs +integer(IK), intent(in) :: idz +real(RP), intent(in) :: bmat(:, :) +real(RP), intent(in) :: zmat(:, :) +real(RP), intent(in) :: xpt(:, :) + +! Outputs +real(RP) :: err + +! Local variables +character(len=*), parameter :: srname = 'ERRH' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: A(size(xpt, 2), size(xpt, 2)) +real(RP) :: e(3, 3) +real(RP) :: maxabs +real(RP) :: Omega(size(xpt, 2), size(xpt, 2)) +real(RP) :: U(size(xpt, 2), size(xpt, 2)) +real(RP) :: V(size(xpt, 1), size(xpt, 2)) +real(RP) :: r(size(xpt, 2)) +real(RP) :: s(size(xpt, 1)) +real(RP) :: t(size(xpt, 2)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(npt >= n + 2, 'NPT >= N + 2', srname) + call assert(idz >= 1 .and. idz <= npt - n, '1 <= IDZ <= NPT-N', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT-N-1]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +A = HALF * matprod(transpose(xpt), xpt)**2 +Omega = -matprod(zmat(:, 1:idz - 1), transpose(zmat(:, 1:idz - 1))) + & + & matprod(zmat(:, idz:npt - n - 1), transpose(zmat(:, idz:npt - n - 1))) +maxabs = maxval([ONE, maxval(abs(A)), maxval(abs(Omega)), maxval(abs(bmat))]) +U = eye(npt) - matprod(A, Omega) - matprod(transpose(xpt), bmat(:, 1:npt)) +V = -matprod(bmat(:, 1:npt), A) - matprod(bmat(:, npt + 1:npt + n), xpt) +r = sum(U, dim=1) / real(npt, RP) +s = sum(V, dim=2) / real(npt, RP) +t = -matprod(A, r) - matprod(s, xpt) +e(1, 1) = maxval(maxval(U, dim=1) - minval(U, dim=1)) +e(1, 2) = maxval(t) - minval(t) +e(1, 3) = maxval(maxval(V, dim=2) - minval(V, dim=2)) +e(2, 1) = maxval(abs(sum(Omega, dim=1))) +e(2, 2) = abs(sum(r) - ONE) +e(2, 3) = maxval(abs(sum(bmat(:, 1:npt), dim=2))) +e(3, 1) = maxval(abs(matprod(xpt, Omega))) +e(3, 2) = maxval(abs(matprod(xpt, r))) +e(3, 3) = maxval(abs(matprod(xpt, transpose(bmat(:, 1:npt))) - eye(n))) +err = maxval(e) / (maxabs * real(n + npt, RP)) + +!====================! +! Calculation ends ! +!====================! + +end function errh + + +subroutine updateh(knew, kref, d, xpt, idz, bmat, zmat, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates arrays [BMAT, ZMAT, IDZ], in order to replace the interpolation point +! XPT(:, KNEW) by XNEW = XPT(:, KREF) + D, where KREF usually equals KOPT in practice. See Section 4 +! of the NEWUOA paper. [BMAT, ZMAT, IDZ] describes the matrix H in the NEWUOA paper (eq. 3.12), +! which is the inverse of the coefficient matrix of the KKT system for the least-Frobenius norm +! interpolation problem: ZMAT holds a factorization of the leading NPT*NPT submatrix OMEGA of H, the +! factorization being OMEGA = ZMAT*Diag(S)*ZMAT^T with S(1:IDZ-1)= -1 and S(IDZ : NPT-N-1) = +1; +! BMAT holds the last N ROWs of H except for the (NPT+1)th column. Note that the (NPT + 1)th row and +! (NPT + 1)th column of H are not stored as they are unnecessary for the calculation. The matrix +! H is also formulated in (2.7) of the BOBYQA paper. Thanks to the RESCUE method (see Section 5 of +! the BOBYQA paper), BOBYQA does not have IDZ (equivalent to IDZ = 1). +! +! N.B.: +! 1. What is H? As mentioned above, it is the inverse of the coefficient matrix of the KKT system +! for the lest-Frobenius norm interpolation problem. Moreover, we should note that the K-th column +! of H contain the coefficients of the K-th Lagrange function LFUNC_K for this interpolation problem, +! where 1 <= K <= NPT. More specifically, the first NPT entries of H(:, K) provide the parameters +! for the Hessian of LFUNC_K so that nabla^2 LFUNC_K = sum_{I=1}^NPT H(I, K) XPT(:, I)*XPT(:, I)^T; +! the last N entries of H(:, K) constitute precisely the gradient of LFUNC_K at the base point XBASE. +! Recalling that H is represented by OMEGA and BMAT in the block form elaborated above, we can see +! OMEGA(:, K) contains the leading NPT entries of H(:, K), while BMAT(:, K) contains the last N. +! 2. Powell's code normally invokes this subroutine with KREF set to KOPT, which is the index of the +! current best interpolation point (also the current center of the trust region). In theory, the +! update should however be independent of KREF. The most natural version (not necessarily the best +! one in practice) of UPDATEH should work based on [KNEW, XNEW - XPT(:,KNEW)] rather than +! [KNEW, KREF, D]. UPDATEH needs KREF only for calculating VLAG and BETA, where XPT(:, KREF) is used +! as a reference point that can be any column of XPT in precise arithmetic. Using XPT(:, KNEW) as +! the reference point, VLAG and BETA can be calculated by +! !VLAG = CALVLAG(KNEW, BMAT, XNEW - XPT(:, KNEW), XPT, ZMAT, IDZ) +! !BETA = CALBETA(KNEW, BMAT, XNEW - XPT(:, KNEW), XPT, ZMAT, IDZ) +! Theoretically (but not numerically), they should return the same VLAG and BETA as the calls below. +! However, as observed on 20220412, such an implementation can lead to significant errors in H! +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, DAMAGING_ROUNDING +use, non_intrinsic :: linalg_mod, only : matprod, planerot, symmetrize, issymmetric, outprod!, r2update +use, non_intrinsic :: string_mod, only : num2str +implicit none + +! Inputs +integer(IK), intent(in) :: knew +integer(IK), intent(in) :: kref +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! In-outputs +integer(IK), intent(inout) :: idz +real(RP), intent(inout) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(inout) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Outputs +integer(IK), intent(out), optional :: info + +! Local variables +character(len=*), parameter :: srname = 'UPDATEH' +integer(IK) :: j +integer(IK) :: ja +integer(IK) :: jb +integer(IK) :: jl +integer(IK) :: n +integer(IK) :: npt +real(RP) :: alpha +real(RP) :: beta +real(RP) :: denom +real(RP) :: grot(2, 2) +real(RP) :: hcol(size(bmat, 2)) +real(RP) :: scala +real(RP) :: scalb +real(RP) :: sqrtdn +real(RP) :: tau +real(RP) :: temp +real(RP) :: tempa +real(RP) :: tempb +real(RP) :: v1(size(bmat, 1)) +real(RP) :: v2(size(bmat, 1)) +real(RP) :: vlag(size(bmat, 2)) + +! Debugging variables +!real(RP) :: beta_test +!real(RP) :: tol +!real(RP), allocatable :: vlag_test(:) +!real(RP), allocatable :: xpt_test(:, :) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(kref >= 1 .and. kref <= npt, '1 <= KREF <= NPT', srname) + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + + do j = 1, npt + hcol(1:npt) = omega_col(idz, zmat, j) + hcol(npt + 1:npt + n) = bmat(:, j) + call assert(precision(0.0_RP) < precision(0.0D0) .or. sum(abs(hcol)) > 0, 'Column '//num2str(j)//' of H is nonzero', srname) + end do + + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + + ! Theoretically, CALVLAG and CALBETA should be independent of the reference point XPT(:, KREF). + ! So we test the following. By the implementation of CALVLAG and CALBETA, we are indeed testing + ! H*[w(X_KREF) - w(X_KNEW)] = e_KREF - e_KNEW. Thus H = W^{-1} is also tested to some extend. + ! However, this is expensive to check. + !if (knew >= 1) then + ! tol = 1.0E-2_RP ! W and H are quite ill-conditioned, so we do not test a high precision. + ! call safealloc(vlag_test, npt + n) + ! vlag_test = calvlag(knew, bmat, d + (xpt(:, kref) - xpt(:, knew)), xpt, zmat, idz) + ! call wassert(all(abs(vlag_test - calvlag(kref, bmat, d, xpt, zmat, idz)) <= & + ! & tol * maxval([ONE, abs(vlag_test)])) .or. precision(0.0_RP) < precision(0.0D0), 'VLAG_TEST == VLAG', srname) + ! deallocate (vlag_test) + ! beta_test = calbeta(knew, bmat, d + (xpt(:, kref) - xpt(:, knew)), xpt, zmat, idz) + ! call wassert(abs(beta_test - calbeta(kref, bmat, d, xpt, zmat, idz)) <= & + ! & tol * max(ONE, abs(beta_test)) .or. precision(0.0_RP) < precision(0.0D0), 'BETA_TEST == BETA', srname) + !end if + + ! The following is too expensive to check. + !call wassert(errh(idz, bmat, zmat, xpt) <= tol .or. precision(0.0_RP) < precision(0.0D0), & + ! & 'H = W^{-1} in (3.12) of the NEWUOA paper', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (present(info)) then + info = INFO_DFT +end if + +! We must not do anything if KNEW is 0. This can only happen sometimes after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +! Set the first NPT components of HCOL to the leading elements of the KNEW-th column of H. Powell's +! code does this after ZMAT is rotated blow, which saves flops but also introduces rounding errors. +hcol(1:npt) = omega_col(idz, zmat, knew) +hcol(npt + 1:npt + n) = bmat(:, knew) + +! Calculate VLAG and BETA according to D. +! VLAG contains the components of the vector H*w of the updating formula (4.11) in the NEWUOA paper, +! and BETA holds the value of the parameter that has this name. +! N.B.: Powell's original comments mention that VLAG is "the vector THETA*WCHECK + e_b of the +! updating formula (6.11)", which does not match the published version of the NEWUOA paper. +vlag = calvlag(kref, bmat, d, xpt, zmat, idz) +beta = calbeta(kref, bmat, d, xpt, zmat, idz) ! Nonnegative in precise arithmetic. + +! Calculate the parameters of the updating formula (4.18)--(4.20) in the NEWUOA paper. +alpha = hcol(knew) ! Nonnegative in precise arithmetic. +tau = vlag(knew) ! Nonzero due to the definition of KNEW. +denom = alpha * beta + tau**2 ! Positive in precise arithmetic. + +! After the following line, VLAG = H*w - e_KNEW in the NEWUOA paper (where t = KNEW). +vlag(knew) = vlag(knew) - ONE + +! Quite rarely, due to rounding errors, VLAG or BETA may not be finite, and ABS(DENOM) may not be +! positive. In such cases, [BMAT, ZMAT] would be destroyed by the update, and hence we would rather +! not update them at all. Or should we simply terminate the algorithm? +if (.not. (is_finite(sum(abs(hcol)) + sum(abs(vlag)) + abs(beta)) .and. abs(denom) > 0)) then + if (present(info)) then + info = DAMAGING_ROUNDING + end if + return +end if + +! Update the matrix BMAT. It implements the last N rows of (4.11) in the NEWUOA paper. +v1 = (alpha * vlag(npt + 1:npt + n) - tau * hcol(npt + 1:npt + n)) / denom +v2 = (-beta * hcol(npt + 1:npt + n) - tau * vlag(npt + 1:npt + n)) / denom +bmat = bmat + outprod(v1, vlag) + outprod(v2, hcol) !call r2update(bmat, ONE, v1, vlag, ONE, v2, hcol) +! N.B.: The use of OUTPROD is expensive memory-wise, but it is not our concern in this implementation. +! Numerically, the update above does not guarantee BMAT(:, NPT+1 : NPT+N) to be symmetric. +call symmetrize(bmat(:, npt + 1:npt + n)) + +! Apply Givens rotations to put zeros in the KNEW-th row of ZMAT and set JL. After this, +! ZMAT(KNEW, :) contains at most two nonzero entries ZMAT(KNEW, 1) and ZMAT(KNEW, JL), one +! corresponding to all the columns of ZMAT that has a coefficient -1 in the factorization of +! OMEGA (if any), and the other corresponding to all the columns with +1. In specific, +! 1. If IDZ = 1 (all coefficients are +1 for the columns of ZMAT in the factorization of OMEGA ) or +! NPT - N (all the coefficients are -1), then JL = 1, and ZMAT(KNEW, 1) is L2-norm of ZMAT(KNEW, :); +! 2. If 2 <= IDZ <= NPT - N -1, then JL = IDZ, and ZMAT(KNEW, 1) is L2-norm of ZMAT(KNEW, 1 : IDZ-1), +! while ZMAT(KNEW, JL) is L2 norm of ZMAT(KNEW, IDZ : NPT-N-1). +! See (4.15)--(4.17) of the NEWUOA paper and the elaboration around them. +jl = 1 ! In the loop below, if 2 <= J < IDZ, then JL = 1; if IDZ < J <= NPT-N-1, then JL = IDZ. +do j = 2, npt - n - 1_IK + if (j == idz) then + jl = idz ! Do nothing but changing JL from 1 to IDZ. It occurs at most once along the loop. + cycle + end if + + ! Powell's condition in NEWUOA/LINCOA for the IF ... THEN below: IF (ZMAT(KNEW, J) /= 0) THEN + ! A possible alternative: IF (ABS(ZMAT(KNEW, J)) > 1.0E-20 * ABS(ZMAT(KNEW, JL))) THEN + if (abs(zmat(knew, j)) > 1.0E-20 * maxval(abs(zmat))) then ! Threshold comes from Powell's BOBYQA + ! Multiply a Givens rotation to ZMAT from the right so that ZMAT(KNEW, [JL,J]) becomes [*,0]. + grot = planerot(zmat(knew, [jl, j])) !!MATLAB: grot = planerot(zmat(knew, [jl, j])') + zmat(:, [jl, j]) = matprod(zmat(:, [jl, j]), transpose(grot)) + end if + zmat(knew, j) = ZERO +end do + +sqrtdn = sqrt(abs(denom)) + +if (jl == 1) then + ! Complete the updating of ZMAT when there is only 1 nonzero in ZMAT(KNEW, :) after the rotation. + ! This is the normal case, as IDZ = 1 in precise arithmetic; it also covers the rare case that + ! IDZ = NPT-N, meaning that OMEGA = -ZMAT*ZMAT^T. See (4.18) of the NEWUOA paper for details. + ! Note that (4.18) updates Z_{NPT-N-1}, but the code here updates ZMAT(:, 1). Correspondingly, + ! we implicitly update S_1 to SIGN(DENOM)*S_1 according to (4.18). If IDZ = NPT-N before the + ! update, then IDZ is reduced by 1, and we need to switch ZMAT(:, 1) and ZMAT(:, IDZ) to maintain + ! that S_J = -1 iff 1 <= J < IDZ, which is done after the END IF together with another case. + + !----------------------------------------------------------------------------------------------! + ! Up to now, TEMPA = ZMAT(KNEW, 1) if IDZ = 1 and TEMPA = -ZMAT(KNEW, 1) if IDZ >= 2. However, + ! according to (4.18) of the NEWUOA paper, TEMPB should always be ZMAT(KNEW, 1)/SQRTDN + ! regardless of IDZ. Therefore, the following definition of TEMPB is inconsistent with (4.18). + ! This is probably a BUG. See also Lemma 4 and (5.13) of Powell's paper "On updating the inverse + ! of a KKT matrix". However, the inconsistency is hardly observable in practice, because JL = 1 + ! implies IDZ = 1 in precise arithmetic. + !--------------------------------------------! + ! !tempb = tempa/sqrtdn + ! !tempa = tau/sqrtdn + !--------------------------------------------! + ! Here is the corrected version (only TEMPB is changed). + tempa = tau / sqrtdn + tempb = zmat(knew, 1) / sqrtdn + !----------------------------------------------------------------------------------------------! + + ! The following line updates ZMAT(:, 1) according to (4.18) of the NEWUOA paper. + zmat(:, 1) = tempa * zmat(:, 1) - tempb * vlag(1:npt) + + !----------------------------------------------------------------------------------------------! + ! Zaikun 20220411: The update of IDZ is decoupled from the update of ZMAT, located after END IF. + !----------------------------------------------------------------------------------------------! + ! The following six lines from Powell's NEWUOA code are obviously problematic --- SQRTDN is + ! always nonnegative. According to (4.18) of the NEWUOA paper, "SQRTDN < 0" and "SQRTDN >= 0" + ! below should be both revised to "DENOM < 0". See also the corresponding part of the LINCOA + ! code. Note that the NEWUOA paper uses SIGMA to denote DENOM. Check also Lemma 4 and (5.13) of + ! Powell's paper "On updating the inverse of a KKT matrix". Note that the BOBYQA code does not + ! have this part, as it does not have IDZ at all. + ! !if (idz == 1 .and. sqrtdn < 0) then + ! ! idz = 2 + ! !end if + ! !if (idz >= 2 .and. sqrtdn >= 0) then + ! ! reduce_idz = .true. + ! !end if + ! This is the corrected version, copied from LINCOA. + ! !if (denom < 0) then + ! ! if (idz == 1) then + ! ! idz = 2 + ! ! else + ! ! reduce_idz = .true. + ! ! end if + ! !end if + !----------------------------------------------------------------------------------------------! +else + ! Complete the updating of ZMAT in the alternative case: ZMAT(KNEW, :) has 2 nonzeros. See (4.19) + ! and (4.20) of the NEWUOA paper. + ! First, set JA and JB so that ZMAT(: [JA, JB]) corresponds to [Z_1, Z_2] in (4.19) when BETA>=0, + ! and corresponds to [Z2, Z1] in (4.20) when BETA<0. In this way, the update of ZMAT(:, [JA, JB]) + ! follows the same scheme regardless of BETA. Indeed, since S_1 = 1 and S_2 = -1 in (4.19)-(4.20) + ! as elaborated above the equations, ZMAT(:, [1, JL]) always correspond to [Z_2, Z_1]. + if (beta >= 0) then ! ZMAT(:, [JA, JB]) corresponds to [Z_1, Z_2] in (4.19) + ja = jl + jb = 1 + else ! ZMAT(:, [JA, JB]) corresponds to [Z_2, Z_1] in (4.20) + ja = 1 + jb = jl + end if + ! Now update ZMAT(:, [ja, jb]) according to (4.19)--(4.20) of the NEWUOA paper. + temp = zmat(knew, jb) / denom + !tempa = temp * beta + !tempb = temp * tau + tempa = (beta / denom) * zmat(knew, jb) + tempb = (tau / denom) * zmat(knew, jb) + temp = zmat(knew, ja) + scala = ONE / sqrt(abs(beta) * temp**2 + tau**2) ! 1/SQRT(ZETA) in (4.19)-(4.20) of NEWUOA paper + scalb = scala * sqrtdn + zmat(:, ja) = scala * (tau * zmat(:, ja) - temp * vlag(1:npt)) + zmat(:, jb) = scalb * (zmat(:, jb) - tempa * hcol(1:npt) - tempb * vlag(1:npt)) + + !----------------------------------------------------------------------------------------------! + ! Zaikun 20220411: The update of IDZ is decoupled from the update of ZMAT, located after END IF. + !----------------------------------------------------------------------------------------------! + ! If and only if DENOM < 0, IDZ will be revised according to the sign of BETA. + ! See (4.19)--(4.20) of the NEWUOA paper. + ! !if (denom < 0) then + ! ! if (beta < 0) then + ! ! idz = idz + 1_IK + ! ! else + ! ! reduce_idz = .true. + ! ! end if + ! !end if + !----------------------------------------------------------------------------------------------! +end if + +!--------------------------------------------------------------------------------------------------! +! Zaikun 20220411: The update of IDZ is decoupled from the update of ZMAT, located right below. +!--------------------------------------------------------------------------------------------------! +! IDZ is reduced in the following case. Then exchange ZMAT(:, 1) and ZMAT(:, IDZ). +! !if (reduce_idz) then +! ! idz = idz - 1_IK +! ! if (idz > 1) then +! ! zmat(:, [1_IK, idz]) = zmat(:, [idz, 1_IK]) +! ! end if +! !end if +!--------------------------------------------------------------------------------------------------! + +! According to (4.18) and (4.19)--(4.20) of the NEWUOA paper, the coefficients {S_J} need update iff +! DENOM < 0, in which case one of the S_J will flip the sign when multiplied by SIGN(DENOM), leading +! to an increase of IDZ (if S_J flipped from 1 to -1) or a decrease (if S_J flipped from -1 to 1). +if (denom < 0) then + if (idz == 1 .or. (idz < npt - n .and. beta < 0)) then ! (4.18), (4.20) of the NEWUOA paper + idz = idz + 1_IK + elseif (idz == npt - n .or. (idz > 1 .and. beta >= 0)) then ! (4.18), (4.19) of the NEWUOA paper + idz = idz - 1_IK + ! Exchange ZMAT(:, 1) and ZMAT(:. IDZ) if IDZ > 1. Why? No matter whether the update is + ! given by (4.18) (IDZ = NPT-N) or (4.19) (1 < IDZ < NPT-N and BETA >= 0), we have S_1 = +1 + ! and S_{IDZ} = -1 at this moment (unless IDZ = 1). Thus we need to exchange ZMAT(:, 1) with + ! ZMAT(:, IDZ) and implicitly S_1 with S_IDZ to maintain that S_J = -1 iff 1 <= J < IDZ. + ! Note that, in the case of (4.18), ZMAT(:, 1) (and implicitly S_1) rather than + ! ZMAT(:, NPT-N-1) was updated by the code above. + if (idz > 1) then + zmat(:, [1_IK, idz]) = zmat(:, [idz, 1_IK]) + end if + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, 'SIZE(ZMAT) == [NPT, NPT-N-1]', srname) + + do j = 1, npt + hcol(1:npt) = omega_col(idz, zmat, j) + hcol(npt + 1:npt + n) = bmat(:, j) + call assert(precision(0.0_RP) < precision(0.0D0) .or. sum(abs(hcol)) > 0, 'Column '//num2str(j)//' of H is nonzero', srname) + end do + + ! The following is too expensive to check. + !call safealloc(xpt_test, n, npt) + !xpt_test = xpt + !xpt_test(:, knew) = xpt(:, kref) + d + !call wassert(errh(idz, bmat, zmat, xpt_test) <= tol .or. precision(0.0_RP) < precision(0.0D0), & + ! & 'H = W^{-1} in (3.12) of the NEWUOA paper', srname) + !deallocate (xpt_test) +end if +end subroutine updateh + + +!--------------------------------------------------------------------------------------------------! +! CALVLAG, CALBETA, and CALDEN are subroutine that calculate VLAG, BETA, and DEN for a given step D. +! VLAG(K), BETA, and DEN(K) are critical for the updating procedure of H when the interpolation set +! replaces XPT(:, K) with D. The updating formula of H is detailed in (4.11) of the NEWUOA paper, +! where the point being replaced is XPT(:, t). See (4.12) for the definition of BETA; VLAG is indeed +! H*w without the (NPT+1)the entry; DEN(t) is SIGMA in (4.12). (4.25)--(4.26) formulate the actual +! calculating scheme of VLAG and BETA. +! +! Zaikun 20250806: In theory, ALPHA and BETA are both nonnegative (see Lemma 2 of Powell 2002, Least +! Frobenius norm updating of quadratic models that satisfy interpolation conditions), and DEN is +! positive. Numerically, however, they can be negative due to rounding errors. Powell's code handles +! such cases carefully. See the UPDATEH subroutine and Section 4 of the NEWUOA paper, especially the +! discussions around (4.21)--(4.22). +! +! In languages like MATLAB/Python/Julia/R, CALVLAG and CALBETA should be implemented into one single +! function, as they share most of the calculation. We separate them in Fortran (at the expense of +! repeating some calculation) because Fortran functions can only have one output. +! +! Explanation on the matrix H in (3.12) and w(X) in (6.3) of the NEWUOA paper and WCHECK in the code: +! 0. As defined in (6.3) of the paper w(X)(K) = 0.5*[(X-X_0)^T*(X_K-X_0)]^2 for K = 1, ..., NPT, +! w(X)(NPT+1) = 1, and w(X)(NPT+2:NPT+N+1) = X - X_0. As in (3.12) of the paper, w(X_K) is the K-th +! column in the coefficient matrix W of the KKT system for the interpolation problem +! Minimize ||nabla^2 Q||_F s.t. Q(X_K) = Y_K, K = 1, ..., NPT. +! This is why w(X) is ubiquitous in the code. +! 1. By (3.9) of the paper, the solution to the above interpolation problem is Q(X) = Y^T*H*w(X), +! with H = W^{-1}, and Y being the vector [Y_1; ...; Y_NPT; 0; ...; 0] with N trailing zeros. In +! particular, the K-th Lagrange function of this interpolation problem is e_K^T*H*w(X), namely the +! K-th entry of the vector H*w(X). This is why H*w(X) appears as the vector VLAG in the code. +! As a consequence, SUM(VLAG(1:NPT)) = 1 in theory. +! 2. As above, H can provide us interpolants and the Lagrange functions. Thus the code maintains H. +! Indeed, the K-th column of H contain the coefficients of the K-th Lagrange function LFUNC_K, +! where 1 <= K <= NPT. More specifically, the first NPT entries of H(:, K) provide the parameters +! for the Hessian of LFUNC_K so that nabla^2 LFUNC_K = sum_{I=1}^NPT H(I, K) XPT(:, I)*XPT(:, I)^T; +! the last N entries of H(:, K) constitute precisely the gradient of LFUNC_K at the base point X_0. +! Recalling that H (except for the (NPT+1)the row and column) is represented by OMEGA and BMAT in +! the block form [OMEGA, BMAT(:, 1:NPT)'; BMAT(:, 1:NPT), BMAT(:, NPT+1:NPT+N)], we can see +! OMEGA(:, K) contains the leading NPT entries of H(:, K), while BMAT(:, K) contains the last N. +! Hence, if X corresponds to XOPT + D, then for K /= KOPT, the K-th entry of VLAG = H*w(X) equals +! LFUNC_K(X_0 + XOPT + D) - LFUNC_K(X_0 + XOPT) = QUADINC_DX(D, X, XPT, BMAT(:, K), OMEGA(:, K)), +! because LFUNC_K(X_0 + XOPT) = 0; for K = KOPT, it equals +! LFUNC_K(X_0 + XOPT + D)-LFUNC_K(X_0 + XOPT)+1 = QUADINC_DX(D, X, XPT, BMAT(:, K), OMEGA(:, K)) + 1, +! as LFUNC_K(X_0 + XOPT) = 1 in this case. +! 3. Since the matrix H is W^{-1} as defined in (3.12) of the paper, we have H*w(X_K) = e_K for +! any K in {1, ..., NPT}. +! 4. When the interpolation set is updated by replacing X_K with X, W is correspondingly updated by +! changing the K-th column from w(X_K) to w(X). This is why the update of H = W^{-1} must involve +! H*[w(X) - w(X_K)] = H*w(X) - e_K. +! 5. As explained above, the vector H*w(X) is essential to the algorithm. The quantity w(X)^T*H*w(X) +! is also needed in the update of H (particularly by BETA). However, they can be tricky to calculate, +! because much cancellation can happen when X_0 is far away from the interpolation set, as explained +! in (7.8)--(7.10) of the paper and the discussions around. To overcome the difficulty, we take +! an integer KREF in {1, ..., NPT}, use XPT(:, KREF) as a reference point, and note that +! H*w(X) = H*[w(X) - w(X_KREF)] + H*w(X_KREF) = H*[w(X) - w(X_KREF)] + e_KREF, and +! w(x)^T*H*w(X) = [w(X) - w(X_KREF)]^T*H*[w(X) - w(X_KREF)] + 2*w(X)(KREF) - w(X_KREF)(KREF), +! The dependence of w(X)-w(X_KREF) on X_0 is weaker, which reduces (but does not resolve) the +! difficulty. In theory, these formulas are invariant with respect to KREF. In the code, this means +! CALVLAG(KREF, BMAT, X - XPT(:, KREF), XPT, ZMAT, IDZ) and +! CALBETA(KREF, BMAT, X - XPT(:, KREF), XPT, ZMAT, IDZ) +! are invariant with respect to KREF. Powell's code normally uses KREF = KOPT. +! 6. Since the (NPT+1)-th entry of w(X) - w(X_KREF) is 0, the above formulas do not require the +! (NPT+1)-th column of H, which is not stored in the code. +! 7. In the code, WCHECK contains the first NPT entries of w-v for the vectors w and v in (4.10) and +! (4.24) of the NEWUOA paper, with w = w(X) and v = w(X_KREF) (KREF = KOPT in the paper); it is +! also hat{w} in (6.5) of M. J. D. Powell, Least Frobenius norm updating of quadratic models that +! satisfy interpolation conditions. Math. Program., 100:183--215, 2004 (KREF = b in the paper). +! 8. Assume that the ||D|| ~ DELTA, ||XPT|| ~ ||XREF||, and DELTA < ||XREF||. Then WCHECK is of the +! order DELTA*||XREF||^3, which can be huge at the beginning of the algorithm and quickly become tiny. +!--------------------------------------------------------------------------------------------------! + +function calvlag_lfqint(kref, bmat, d, xpt, zmat, idz) result(vlag) +!--------------------------------------------------------------------------------------------------! +! This function calculates VLAG = H*w for a given step D with respect to XREF = XPT(:, KREF). This +! subroutine is usually invoked with KREF = KOPT, which correspond to the current best interpolation +! point as well as the center of the trust region. See (4.25) of the NEWUOA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, HALF, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert, wassert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : matprod, issymmetric + +implicit none + +! Inputs +integer(IK), intent(in) :: kref +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) +integer(IK), intent(in), optional :: idz ! Absent in BOBYQA, being equivalent to IDZ = 1 + +! Outputs +real(RP) :: vlag(size(xpt, 1) + size(xpt, 2)) ! VLAG(NPT + N) + +! Local variables +character(len=*), parameter :: srname = 'CALVLAG' +integer(IK) :: idz_loc +integer(IK) :: n +integer(IK) :: npt +real(RP) :: tol ! For debugging only +real(RP) :: wcheck(size(zmat, 1)) +real(RP) :: xref(size(xpt, 1)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Read IDZ, which is not present in BOBYQA, being equivalent to IDZ = 1. +idz_loc = 1 +if (present(idz)) then + idz_loc = idz +end if + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz_loc >= 1 .and. idz_loc <= size(zmat, 2) + 1, '1 <= ID <= SIZE(ZMAT, 2) + 1', srname) + call assert(kref >= 1 .and. kref <= npt, '1 <= KREF <= NPT', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +xref = xpt(:, kref) ! Read XREF. + +! Set WCHECK to the first NPT entries of (w-v) for w and v in (4.10) and (4.24) of the NEWUOA paper. +wcheck = matprod(d, xpt) +wcheck = wcheck * (HALF * wcheck + matprod(xref, xpt)) + +! The following two lines set VLAG to H*(w-v). +vlag(1:npt) = omega_mul(idz_loc, zmat, wcheck) + matprod(d, bmat(:, 1:npt)) +vlag(npt + 1:npt + n) = matprod(bmat, [wcheck, d]) +! The following line is equivalent to the above one, but handles WCHECK and D separately. +! !vlag(npt + 1:npt + n) = matprod(bmat(:, 1:npt), wcheck) + matprod(bmat(:, npt + 1:npt + n), d) + +! The following line sets VLAG(KREF) to the correct value. +vlag(kref) = vlag(kref) + ONE + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(vlag) == npt + n, 'SIZE(VLAG) == NPT + N', srname) + tol = max(TEN**max(-8, -MAXPOW10), min(1.0E-1_RP, TEN**min(12, MAXPOW10) * EPS * real(npt + n, RP))) + call wassert(abs(sum(vlag(1:npt)) - ONE) / real(npt, RP) <= tol .or. precision(0.0_RP) < precision(0.0D0), & + & 'SUM(VLAG(1:NPT)) == 1', srname) +end if + +end function calvlag_lfqint + + +function calbeta(kref, bmat, d, xpt, zmat, idz) result(beta) +!--------------------------------------------------------------------------------------------------! +! This function calculates BETA for a given step D with respect to XREF = XPT(:, KREF). This +! subroutine is usually invoked with KREF = KOPT, which correspond to the current best interpolation +! point as well as the center of the trust region. See (4.12) and (4.26) of the NEWUOA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : inprod, matprod, issymmetric + +implicit none + +! Inputs +integer(IK), intent(in) :: kref +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) +integer(IK), intent(in), optional :: idz ! Absent in BOBYQA, being equivalent to IDZ = 1 + +! Outputs +real(RP) :: beta + +! Local variables +character(len=*), parameter :: srname = 'CALBETA' +integer(IK) :: idz_loc +integer(IK) :: n +integer(IK) :: npt +real(RP) :: dsq +real(RP) :: dvlag +real(RP) :: dxref +real(RP) :: vlag(size(xpt, 1) + size(xpt, 2)) +real(RP) :: wcheck(size(zmat, 1)) +real(RP) :: wmv(size(xpt, 1) + size(xpt, 2)) +real(RP) :: wvlag +real(RP) :: xref(size(xpt, 1)) +real(RP) :: xrefsq + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Read IDZ, which is absent from BOBYQA, being equivalent to IDZ = 1. +idz_loc = 1 +if (present(idz)) then + idz_loc = idz +end if + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz_loc >= 1 .and. idz_loc <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(kref >= 1 .and. kref <= npt, '1 <= KREF <= NPT', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +xref = xpt(:, kref) ! Read XREF. + +!--------------------------------------------------------------------------------------------------! +! N.B.: When checking the NEWUOA paper, note that the paper takes KREF = KOPT and XREF = XOPT. +!--------------------------------------------------------------------------------------------------! + +! Set WCHECK to the first NPT entries of (w-v) for w and v in (4.10) and (4.24) of the NEWUOA paper. +wcheck = matprod(d, xpt) +wcheck = wcheck * (HALF * wcheck + matprod(xref, xpt)) + +! WMV is the vector (w-v) for w and v in (4.10) and (4.24) of the NEWUOA paper. +wmv = [wcheck, d] +! The following two lines set VLAG to H*(w-v). +vlag(1:npt) = omega_mul(idz_loc, zmat, wcheck) + matprod(d, bmat(:, 1:npt)) +vlag(npt + 1:npt + n) = matprod(bmat, wmv) +! The following line is equivalent to the above one, but handles WCHECK and D separately. +! !VLAG(NPT + 1:NPT + N) = MATPROD(BMAT(:, 1:NPT), WCHECK) + MATPROD(BMAT(:, NPT + 1:NPT + N), D) + +! Set BETA = HALF*||XREF + D||^4 - (W-V)'*H*(W-V) - [XREF'*(X+XREF)]^2 + HALF*||XREF||^4. See +! equations (4.10), (4.12), (4.24), and (4.26) of the NEWUOA paper. +dxref = inprod(d, xref) +dsq = inprod(d, d) +xrefsq = inprod(xref, xref) +dvlag = inprod(d, vlag(npt + 1:npt + n)) +wvlag = inprod(wcheck, vlag(1:npt)) +beta = dxref**2 + dsq * (xrefsq + dxref + dxref + HALF * dsq) - dvlag - wvlag +!---------------------------------------------------------------------------------------------------! +! The last line is equivalent to either of the following lines, but performs better numerically. +! !BETA = DXREF**2 + DSQ * (XREFSQ + DXREF + DXREF + HALF * DSQ) - INPROD(VLAG, WMV) ! not good +! !BETA = DXREF**2 + DSQ * (XREFSQ + DXREF + DXREF + HALF * DSQ) - WVLAG - DVLAG ! bad +!---------------------------------------------------------------------------------------------------! + +! N.B.: +! 1. Mathematically, the following two quantities are equal: +! DXREF**2 + DSQ * (XREFSQ + DXREF + DXREF + HALF * DSQ) , +! HALF * (INPROD(X, X)**2 + INPROD(XREF, XREF)**2) - INPROD(X, XREF)**2 with X = XREF + D. +! However, the first (by Powell) is a better numerical scheme. According to the first formulation, +! this quantity is in the order of ||D||^2*||XREF||^2 if ||XREF|| >> ||D||, which is normally the case. +! However, each term in the second formulation has an order of ||XREF||^4. Thus much cancellation +! will occur in the second formulation. In addition, the first formulation contracts the rounding +! error in (XREFSQ + DXREF + DXREF + HALF * DSQ) by a factor of ||D||^2, which is typically small. +! 2. We can evaluate INPROD(VLAG, WMV) as INPROD(VLAG(1:NPT), WCHECK) + INPROD(VLAG(NPT+1:NPT+N),D) +! if it is desirable to handle WCHECK and D separately due to their significantly different magnitudes. + +! The following line sets VLAG(KREF) to the correct value if we intend to output VLAG. +! !VLAG(KREF) = VLAG(KREF) + ONE + +!====================! +! Calculation ends ! +!====================! + +end function calbeta + + +function calden(kref, bmat, d, xpt, zmat, idz) result(den) +!--------------------------------------------------------------------------------------------------! +! This function calculates DEN for a given step D with respect to XREF = XPT(:, KREF). DEN is an +! array of length NPT, and DEN(K) is the value of SIGMA in (4.12) of the NEWUOA paper if XPT(:, K) +! is replaced with XPT(:, KREF)+D. This value appears as a DENominator in the updating formula of +! the matrix H as detailed in (4.11) of the NEWUOA paper. This subroutine is usually invoked with +! KREF = KOPT, which correspond to the current best interpolation point as well as the center of the +! trust region. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : issymmetric + +implicit none + +! Inputs +integer(IK), intent(in) :: kref +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) +integer(IK), intent(in), optional :: idz ! Absent in BOBYQA, being equivalent to IDZ = 1 + +! Outputs +real(RP) :: den(size(xpt, 2)) + +! Local variables +character(len=*), parameter :: srname = 'CALDEN' +integer(IK) :: idz_loc +integer(IK) :: n +integer(IK) :: npt +real(RP) :: beta +real(RP) :: hdiag(size(xpt, 2)) +real(RP) :: vlag(size(xpt, 1) + size(xpt, 2)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Read IDZ, which is absent from BOBYQA, being equivalent to IDZ = 1. +idz_loc = 1 +if (present(idz)) then + idz_loc = idz +end if + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz_loc >= 1 .and. idz_loc <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(kref >= 1 .and. kref <= npt, '1 <= KREF <= NPT', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +hdiag = -sum(zmat(:, 1:idz_loc - 1)**2, dim=2) + sum(zmat(:, idz_loc:size(zmat, 2))**2, dim=2) +vlag = calvlag(kref, bmat, d, xpt, zmat, idz_loc) +beta = calbeta(kref, bmat, d, xpt, zmat, idz_loc) +den = hdiag * beta + vlag(1:npt)**2 + +!====================! +! Calculation ends ! +!====================! + +end function calden + + +function calvlag_qint(pl, d, xref, kref) result(vlag) +!--------------------------------------------------------------------------------------------------! +! This function evaluates VLAG = [LFUNC_1(XREF+D), ..., LFUNC_NPT(XREF+D)] for a quadratic +! interpolation problem, where LFUNC_K is the K-the Lagrange function, and XREF is the KREF-th +! interpolation node. This subroutine is usually invoked with KREF = KOPT, which correspond to the +! current best interpolation point as well as the center of the trust region. +! The coefficients of LFUNC_K are provided by PL(:, K) so that LFUNC_K(Y) = + , +! where G is PL(1:N, K), and HESSIAN is the symmetric matrix whose upper triangular part is stored +! in PL(N+1:N*(N+3)/2, K) column by column. Note the following: +! 1. For K /= KREF, LFUNC_K(XREF + D) = LFUNC_K(XREF + D) - LFUNC_K(XREF) as LFUNC_K(XREF) = 0. +! 2. When K = KREF, LFUNC_K(XREF + D) = LFUNC_K(XREF + D) - LFUNC_K(XREF) + 1 as LFUNC_K(XREF) = 1. +! Therefore, the function first calculates VLAG(K) = QUADINC_GHV(PL(:, K), D, XREF) for each K, and +! then increase VLAG(KREF) by 1. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, HALF, ONE, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : matprod +implicit none +! Inputs +real(RP), intent(in) :: pl(:, :) +real(RP), intent(in) :: d(:) +real(RP), intent(in) :: xref(:) +integer(IK), intent(in) :: kref +! Outputs +real(RP) :: vlag(size(pl, 2)) +! Local variables +character(len=*), parameter :: srname = 'CALVLAG_QINT' +integer(IK) :: ih +integer(IK) :: n +integer(IK) :: j +real(RP) :: s(size(xref)) +real(RP) :: w(size(pl, 1)) + +! Sizes +n = int(size(xref), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(d) == n, 'SIZE(D) = N', srname) + call assert(size(pl, 2) == (n + 1) * (n + 2) / 2 .and. size(pl, 1) == size(pl, 2) - 1, & + & 'SIZE(PL) = [N*(N+3)/2, (N+1)*(N+2)/2]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +s = xref + d + +w(1:n) = d +do j = 1, n + ih = n + (j - 1_IK) * j / 2_IK + w(ih + 1:ih + j) = d(1:j) * s(j) + d(j) * xref(1:j) + w(ih + j) = HALF * w(ih + j) +end do + +vlag = matprod(w, pl) ! VLAG(K) = QUADINC_GHV(PL(:, K), D, XREF) +vlag(kref) = vlag(kref) + ONE + +!====================! +! Calculation ends ! +!====================! + +end function calvlag_qint + + +function setij(n, npt, sorting_direction) result(ij) +!--------------------------------------------------------------------------------------------------! +! Set IJ to a 2-by-(NPT-2*N-1) integer array so that IJ(:, K) = [P(K + 2*N + 1), Q(K + 2*N + 1)], +! with P and Q defined in (2.4) of the BOBYQA paper as well as Section 3 of the NEWUOA paper. +! If NPT <= 2*N + 1, then IJ is empty. Assume that NPT >= 2*N + 2. Then SIZE(IJ) = [2, NPT-2*N-1]. +! IJ contains integers between 1 and N. When NPT = (N+1)*(N+2)/2, the columns of IJ correspond to +! a permutation of {{I, J} : 1 <= I /= J <= N}; when NPT < (N+1)*(N+2)/2, they correspond to the +! first NPT - 2*N - 1 elements of such a permutation. The permutation is enumerated first in the +! ascending order of |I - J| and then in the ascending order of MAX{I, J}. We do not distinguish +! between {I, J} and {J, I}, which represent the same set. If we want to ensure IJ(1, :) > IJ(2, :), +! then we can specify SORTING_DIRECTION = 'descend'. +! +! This function is used in the initialization of NEWUOA, BOBYQA, and LINCOA. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : sort +use, non_intrinsic :: string_mod, only : lower +implicit none + +! Inputs +integer(IK), intent(in) :: n +integer(IK), intent(in) :: npt +character(len=*), intent(in), optional :: sorting_direction +! Outputs +integer(IK) :: ij(2, max(0_IK, npt - 2_IK * n - 1_IK)) +! Local variables +character(len=*), parameter :: srname = 'SETIJ' +integer(IK) :: k +integer(IK) :: ell(max(0_IK, npt - 2_IK * n - 1_IK)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +ell = int([(k, k=n, npt - n - 2_IK)] / n, IK) ! The ell below (2.4) of the BOBYQA paper. +ij(1, :) = [(k, k=n, npt - n - 2_IK)] - n * ell + 1_IK +ij(2, :) = modulo(ij(1, :) + ell - 1_IK, n) + 1_IK ! MODULO(K-1, N) + 1 = K-N for K in [N+1, 2N] +if (present(sorting_direction)) then + ij = sort(ij, 1, sorting_direction) ! SORTING_DIRECTION is 'DESCEND' of 'ASCEND' +end if +!!MATLAB: (N.B.: Fortran MODULO == MATLAB `mod`, Fortran MOD == MATLAB `rem`) +!!ell = floor((n : npt-n-2) / n); +!!ij(1, :) = (n : npt-n-2) - n*ell + 1; +!!ij(2, :) = mod(ij(1, :) + ell - 1, n) + 1; % mod(k-1,n) + 1 = k-n for k in [n+1,2n] +!!if nargin >= 3 +!! ij = sort(ij, 2, sorting_direction) % `sorting_direction` is 'descend' of 'ascend' +!!end + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(all(ij >= 1 .and. ij <= n), '1 <= IJ <= N', srname) + if (present(sorting_direction)) then + if (lower(sorting_direction) == 'descend') then + call assert(all(ij(1, :) > ij(2, :)), 'IJ(1, :) > IJ(2, :)', srname) + elseif (lower(sorting_direction) == 'ascend') then + call assert(all(ij(1, :) < ij(2, :)), 'IJ(1, :) < IJ(2, :)', srname) + end if + else + call assert(all(ij(1, :) /= ij(2, :)), 'IJ(1, :) /= IJ(2, :)', srname) + end if +end if +end function setij + + +end module powalg_mod diff --git a/examples/fortran/prima/native/common/ppf.h b/examples/fortran/prima/native/common/ppf.h new file mode 100644 index 000000000..e6a93d6da --- /dev/null +++ b/examples/fortran/prima/native/common/ppf.h @@ -0,0 +1,180 @@ +/******************************************************************************/ +/* + * Coded by Zaikun ZHANG (www.zhangzk.net) in July 2020. + * + * Last Modified: Tue 11 April 2022 04:53:00 PM HKT + */ +/******************************************************************************/ +/* + * ppf.h defines the following preprocessing macros (the first value is default). + * + * PRIMA_FORTRAN_STANDARD which Fortran standard to follow: 2008, 2018, 2023 + * PRIMA_RELEASED released or not: 1, 0 + * PRIMA_DEBUGGING debug or not: 0, 1 + * PRIMA_INTEGER_KIND the integer kind to be used: 0, 16, 32, 64 + * PRIMA_REAL_PRECISION the real precision to be used: 64, 16, 32, 128, 0 + * PRIMA_QP_AVAILABLE quad precision available or not: 0, 1 + * PRIMA_MAX_HIST_MEM_MB maximal MB memory for computation history: 300 + * PRIMA_AGGRESSIVE_OPTIONS compile the code with aggressive options: 0, 1 + * + * N.B.: + * + * 0. USE THE DEFAULT IF UNSURE. + * + * 1. The macros can be modified by the -D option of the compilers. For example, + * -DPRIMA_DEBUGGING=1 will set PRIMA_DEBUGGING to 1. + * + * 2. All the macros defined here starts with "PRIMA_". We avoid the following + * patterns, as C and C++ reserve them for the implementation of the languages. + * - Begins with two underscores + * - Begins with underscore and uppercase letter + * - Begins with underscore and something else + * - Contains two consecutive underscores + * See https://devblogs.microsoft.com/oldnewthing/20230109-00/?p=107685. + * + * 3. Setting PRIMA_MAX_HIST_MEM_MB to a big value may lead to segfaults due to + * large arrays. + * + * 4. If you change these macros, make sure that your compiler is supportive + * when changing PRIMA_INTEGER_KIND and PRIMA_REAL_PRECISION. + * + * 5. Why not define these macros as parameters in the Fortran code, e.g., + * + * logical, parameter :: PRIMA_DEBUGGING == .false. ? + * + * Such a definition will work for PRIMA_DEBUGGING, but not for the macros + * that depend on the compiler. In addition, we can change the value of the + * macros by the -D option of the compilers, which is impossible if we code + * them as parameters in the Fortran code. + * + */ +/******************************************************************************/ + + +/******************************************************************************/ +#if !defined PRIMA_PPF_H /* include guard to avoid double inclusion */ +#define PRIMA_PPF_H +/******************************************************************************/ + + +/******************************************************************************/ +/* Which Fortran standard to follow? + * N.B.: 1. The value of PRIMA_FORTRAN_STANDARD is NOT used in the code. We + * define it only for the purpose of a record. + * 2. With gfortran, due to `error stop` and `backtrace`, we must either compile + * with no `-std` or use `-std=f20xy -fall-intrinsics` with xy >= 18. */ +#if !defined PRIMA_FORTRAN_STANDARD +#define PRIMA_FORTRAN_STANDARD 2008 /* Default to 2018 later (in 2025?). */ +#endif +/******************************************************************************/ + + +/******************************************************************************/ +/* Is this a released version? Should be 1 except for the developers. */ +#if !defined PRIMA_RELEASED +#define PRIMA_RELEASED 1 +#endif +/******************************************************************************/ + + +/******************************************************************************/ +/* Are we debugging? + * PRIMA_RELEASED == 1 and PRIMA_DEBUGGING == 1 do not conflict. User may debug.*/ +#if !defined PRIMA_DEBUGGING +#define PRIMA_DEBUGGING 0 +#endif +/******************************************************************************/ + + +/******************************************************************************/ +/* Which integer kind to use? + * 0 = default INTEGER, 16 = INTEGER*2, 32 = INTEGER*4, 64 = INTEGER*8. + * Make sure that your compiler supports the selected kind. */ +#if !defined PRIMA_INTEGER_KIND +#define PRIMA_INTEGER_KIND 0 +#endif +/* Fortran standards guarantee that 0 is supported, but not the others. */ +/******************************************************************************/ + + +/******************************************************************************/ +/* Which real kind to use? + * 0 = default REAL (SINGLE PRECISION), 16 = REAL*2, 32 = REAL*4, 64 = REAL*8, + * 128 = REAL*16. + * Make sure that your compiler supports the selected kind. Note the following: + * 1. The default REAL (i.e., 0) is the single-precision REAL. + * 2. Fortran standards guarantee that 0, 32, and 64 are supported, but not 128. + * 3. If you set PRIMA_REAL_PRECISION to 16, then set PRIMA_HP_AVAILABLE to 1. + * 4. If you set PRIMA_REAL_PRECISION to 128, then set PRIMA_QP_AVAILABLE to 1.*/ +#if !defined PRIMA_REAL_PRECISION +#define PRIMA_REAL_PRECISION 64 +#endif + +/* Is half precision available on this platform (compiler, hardware ...)? */ +/* Set PRIMA_HP_AVAILABLE to 1 and PRIMA_REAL_PRECISION to 16 if REAL*2 is + * available and you REALLY intend to use it. DO NOT DO IT IF NOT SURE. */ +#if !defined PRIMA_HP_AVAILABLE +#if (defined __NAG_COMPILER_BUILD && __NAG_COMPILER_BUILD > 7200) +#define PRIMA_HP_AVAILABLE 1 +#else +#define PRIMA_HP_AVAILABLE 0 +#endif +#endif + +/* Revise PRIMA_REAL_PRECISION according to PRIMA_HP_AVAILABLE . */ +#if PRIMA_HP_AVAILABLE != 1 && PRIMA_REAL_PRECISION < 32 +#undef PRIMA_REAL_PRECISION +#define PRIMA_REAL_PRECISION 32 +#endif + +/* Is quad precision available on this platform (compiler, hardware ...)? */ +/* Note: + * 1. Not all platforms support REAL*16. + * 2. It is not guaranteed that REAL*16 has a wider range than REAL*8. For + * example, REAL*16 of nagfor 7.0 has a range of 291, while REAL*8 + * has a range of 307. + * 3. It is rarely a good idea to use REAL*16 as the working precision, + * which is probably inefficient and unnecessary. + * 4. Set PRIMA_QP_AVAILABLE to 1 and PRIMA_REAL_PRECISION to 128 if REAL*16 + * is available and you REALLY intend to use it. DO NOT DO IT IF NOT SURE. */ +#if !defined PRIMA_QP_AVAILABLE +#if defined __GFORTRAN__ || defined __INTEL_COMPILER || defined __NAG_COMPILER_BUILD +#define PRIMA_QP_AVAILABLE 1 +#else +#define PRIMA_QP_AVAILABLE 0 +#endif +#endif + +/* Revise PRIMA_REAL_PRECISION according to PRIMA_QP_AVAILABLE . */ +#if PRIMA_QP_AVAILABLE != 1 && PRIMA_REAL_PRECISION > 64 +#undef PRIMA_REAL_PRECISION +#define PRIMA_REAL_PRECISION 64 +#endif +/******************************************************************************/ + + +/******************************************************************************/ +/* The maximal memory for recording the computation history (MB). + * The maximal supported value is 2000, as 2000 M = 2*10^9 = maximum of INT32. + * N.B.: A big value (even < 2000) may lead to SEGFAULTs due to large arrays. */ +#if !defined PRIMA_MAX_HIST_MEM_MB +#define PRIMA_MAX_HIST_MEM_MB 300 /* 1MB > 10^5*DOUBLE. 100 can be too small.*/ +#endif +/******************************************************************************/ + + +/******************************************************************************/ +/* Will we compile the code with aggressive options (e.g., -Ofast for gfortran)? + * Some debugging will be disabled if yes (1). Note: + * 1. It is OK to set PRIMA_AGGRESSIVE_OPTIONS = 0 and PRIMA_DEBUGGING = 1 + * simultaneously. + * 2. When compiled with aggressive options, the code may behave unexpectedly.*/ +#if !defined PRIMA_AGGRESSIVE_OPTIONS +#define PRIMA_AGGRESSIVE_OPTIONS 0 +#endif +/******************************************************************************/ + + +/******************************************************************************/ +#endif /* include guard to avoid double inclusion */ +/******************************************************************************/ diff --git a/examples/fortran/prima/native/common/preproc.f90 b/examples/fortran/prima/native/common/preproc.f90 new file mode 100644 index 000000000..7dd0389e3 --- /dev/null +++ b/examples/fortran/prima/native/common/preproc.f90 @@ -0,0 +1,448 @@ +module preproc_mod +!--------------------------------------------------------------------------------------------------! +! PREPROC_MOD is a module that preprocesses the inputs. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and papers. +! +! Started: July 2020 +! +! Last Modified: Mon 06 Apr 2026 10:54:37 PM CST +!--------------------------------------------------------------------------------------------------! + +! N.B.: +! 1. If all the inputs are valid, then PREPROC should do nothing. +! 2. In PREPROC, we use VALIDATE instead of ASSERT, so that the parameters are validated even if we +! are not in debug mode. + +implicit none +private +public :: preproc + + +contains + + +subroutine preproc(solver, n, iprint, maxfun, maxhist, ftarget, rhobeg, rhoend, m, npt, maxfilt, & + & ctol, cweight, eta1, eta2, gamma1, gamma2, is_constrained, has_rhobeg, honour_x0, xl, xu, x0) +!--------------------------------------------------------------------------------------------------! +! This subroutine preprocesses the inputs. It does nothing to the inputs that are valid. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, TWO, TEN, HALF, EPS, MAXHISTMEM, DEBUGGING +use, non_intrinsic :: consts_mod, only : RHOBEG_DFT, RHOEND_DFT, ETA1_DFT, ETA2_DFT, GAMMA1_DFT, GAMMA2_DFT +use, non_intrinsic :: consts_mod, only : CTOL_DFT, CWEIGHT_DFT, IPRINT_DFT, MIN_MAXFILT, MAXFILT_DFT +use, non_intrinsic :: debug_mod, only : validate, warning +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : trueloc, falseloc +use, non_intrinsic :: memory_mod, only : cstyle_sizeof +use, non_intrinsic :: string_mod, only : lower, num2str +implicit none + +! Compulsory inputs +character(len=*), intent(in) :: solver +integer(IK), intent(in) :: n + +! Optional inputs +integer(IK), intent(in), optional :: m +logical, intent(in), optional :: has_rhobeg +logical, intent(in), optional :: honour_x0 +logical, intent(in), optional :: is_constrained +real(RP), intent(in), optional :: xl(:) +real(RP), intent(in), optional :: xu(:) + +! Compulsory in-outputs +integer(IK), intent(inout) :: iprint +integer(IK), intent(inout) :: maxfun +integer(IK), intent(inout) :: maxhist +real(RP), intent(inout) :: eta1 +real(RP), intent(inout) :: eta2 +real(RP), intent(inout) :: ftarget +real(RP), intent(inout) :: gamma1 +real(RP), intent(inout) :: gamma2 +real(RP), intent(inout) :: rhobeg +real(RP), intent(inout) :: rhoend + +! Optional in-outputs +integer(IK), intent(inout), optional :: npt +integer(IK), intent(inout), optional :: maxfilt +real(RP), intent(inout), optional :: ctol +real(RP), intent(inout), optional :: cweight +real(RP), intent(inout), optional :: x0(:) + +! Local variables +character(len=*), parameter :: srname = 'PREPROC' +character(len=:), allocatable :: min_maxfun_str +integer :: min_maxfun ! INTEGER(IK) may overflow if IK corresponds to the 16-bit integer. +integer :: unit_memo ! INTEGER(IK) may overflow if IK corresponds to the 16-bit integer. +integer(IK) :: iprint_in +integer(IK) :: m_loc +integer(IK) :: maxfilt_in +integer(IK) :: maxfun_in +integer(IK) :: maxhist_in +integer(IK) :: npt_in +logical :: is_constrained_loc +logical :: lbx(n) +logical :: ubx(n) +real(RP) :: ctol_in +real(RP) :: cweight_in +real(RP) :: eta1_in +real(RP) :: eta2_in +real(RP) :: gamma1_in +real(RP) :: gamma2_in +real(RP) :: rhobeg_default +real(RP) :: rhobeg_in +real(RP) :: rhoend_default +real(RP) :: rhoend_in +real(RP) :: x0_in(n) + +! Preconditions +if (DEBUGGING) then + call validate(n >= 1, 'N >= 1', srname) + call validate(present(npt) .eqv. (lower(solver) == 'newuoa' .or. lower(solver) == 'bobyqa' .or. & + & lower(solver) == 'lincoa'), 'NPT is present if and only if SOLVER is NEWUOA, BOBYQA, or LINCOA', srname) + if (present(m)) then + call validate(m >= 0, 'M >= 0', srname) + call validate(m == 0 .or. lower(solver) == 'cobyla', 'M == 0 unless the solver is COBYLA', srname) + end if + if (lower(solver) == 'cobyla' .and. present(m) .and. present(is_constrained)) then + call validate(m == 0 .or. is_constrained, 'For COBYLA, M == 0 unless the problem is constrained', srname) + end if + call validate(present(maxfilt) .eqv. (lower(solver) == 'lincoa' .or. lower(solver) == 'cobyla'), & + & 'MAXFILT is present if and only if the solver is LINCOA or COBYLA', srname) + if (lower(solver) == 'bobyqa') then + call validate(present(xl) .and. present(xu), 'XL and XU are present if the solver is BOBYQA', srname) + call validate(all(xu - xl >= TWO * EPS), 'MINVAL(XU-XL) > 2*EPS', srname) + end if + call validate((present(honour_x0) .eqv. present(x0)) .and. (present(honour_x0) .eqv. present(has_rhobeg)), & + & 'HONOUR_X0, X0, and HAS_RHOBEG are present or absent simultaneously', srname) + call validate(present(honour_x0) .eqv. lower(solver) == 'bobyqa', & + & 'HONOUR_X0 is present if and only if the solver is BOBYQA', srname) + ! N.B.: LINCOA and COBYLA will have HONOUR_X0 as well if we intend to make them respect bounds. + ! !call validate(present(honour_x0) .eqv. & + ! ! & (lower(solver) == 'bobyqa' .or. lower(solver) == 'lincoa' .or. lower(solver) == 'cobyla'), & + ! ! & 'HONOUR_X0 is present if and only if the solver is BOBYQA, LINCOA, or COBYLA', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Read M, if necessary +if (lower(solver) == 'cobyla' .and. present(m)) then + m_loc = m +else + m_loc = 0 +end if + +! Decide whether the problem is truly constrained +if (present(is_constrained)) then + is_constrained_loc = is_constrained +else + is_constrained_loc = (m_loc > 0) +end if + +! Validate IPRINT +if (abs(iprint) > 3) then + iprint_in = iprint + iprint = IPRINT_DFT + call warning(solver, 'Invalid IPRINT: '//num2str(iprint_in)// & + & '; it should be 0, 1, -1, 2, -2, 3, or -3; it is set to '// num2str(iprint)) +end if + +! Validate MAXFUN +! N.B.: The INT(N), INT(N+1), and INT(N+2) below convert integers to the default integer kind, +! which is the kind of MIN_MAXFUN. Fortran compilers may complain without the conversion. It is +! not needed in Python/MATLAB/Julia/R. +select case (lower(solver)) +case ('uobyqa') + min_maxfun = (int(n + 1) * int(n + 2)) / 2 + 1 ! INT(*) avoids overflow when IK is 16-bit. + min_maxfun_str = '(N+1)(N+2)/2 + 1' +case ('cobyla') + min_maxfun = int(n) + 2 + min_maxfun_str = 'N + 2' +case default ! CASE ('NEWUOA', 'BOBYQA', 'LINCOA') + min_maxfun = int(n) + 3 + min_maxfun_str = 'N + 3' +end select +if (maxfun <= max(0, min_maxfun - 1)) then + maxfun_in = maxfun + if (maxfun > 0) then + maxfun = int(min_maxfun, kind(maxfun)) + else ! We assume that non-positive values of MAXFUN are produced by overflow. + maxfun = int(max(min_maxfun, 10**min(4, range(maxfun))), kind(maxfun)) !!MATLAB: maxfun = max(min_maxfun, 10^4); + ! N.B.: Do NOT set MAXFUN to HUGE(MAXFUN), as it may cause overflow and infinite cycling + ! when used as the upper bound of DO loops. This occurred on 20240225 with gfortran 13. See + ! https://fortran-lang.discourse.group/t/loop-variable-reaching-integer-huge-causes-infinite-loop + ! https://fortran-lang.discourse.group/t/loops-dont-behave-like-they-should + end if + call warning(solver, 'Invalid MAXFUN: '//num2str(maxfun_in)// & + & '; it should be at least '//min_maxfun_str//' with N = '//num2str(n)//'; it is set to '//num2str(maxfun)) +end if + +! Validate MAXHIST +if (maxhist <= 0) then + maxhist_in = maxhist + maxhist = maxfun + call warning(solver, 'Invalid MAXHIST: '//num2str(maxhist_in)// & + & '; it should be a positive integer; it is set to '//num2str(maxhist)) +end if +maxhist = min(maxhist, maxfun) ! MAXHIST > MAXFUN is never needed. + +! Validate FTARGET +if (is_nan(ftarget)) then ! No warning if FTARGET is NaN, which is interpreted as no target function value is provided. + ftarget = -huge(ftarget) +end if + +! Validate NPT +if (present(npt)) then + if (npt < n + 2 .or. npt >= maxfun .or. 2 * int(npt) > int(n + 2) * int(n + 1)) then !INT(*) avoids overflow when IK is 16-bit + npt_in = npt + npt = int(min(maxfun - 1, 2 * n + 1), kind(npt)) + call warning(solver, 'Invalid NPT: '//num2str(npt_in)// & + & '; it should be an integer in the interval [N+2, (N+1)(N+2)/2] with N = '//num2str(n)// & + & ' and less than MAXFUN = '//num2str(maxfun)//'; it is set to '//num2str(npt)) + end if +end if + +! Validate MAXFILT +if (present(maxfilt)) then + maxfilt_in = maxfilt + if (maxfilt <= 0) then + maxfilt = MAXFILT_DFT + else + maxfilt = max(MIN_MAXFILT, maxfilt) ! The inputted MAXFILT is too small. + end if + ! Further revise MAXFILT according to MAXHISTMEM. + select case (lower(solver)) + case ('lincoa') + unit_memo = int(n + 2) * int(cstyle_sizeof(0.0_RP)) ! INT(*) avoids overflow when IK is 16-bit. + case ('cobyla') + unit_memo = int(m_loc + n + 2) * int(cstyle_sizeof(0.0_RP)) ! INT(*) avoids overflow when IK is 16-bit. + case default ! The following should not be reached unless there is a bug, but we keep it for safety. + unit_memo = 1 + end select + ! We cannot simply set MAXFILT = MIN(MAXFILT, MAXHISTMEM/...), as they may not have + ! the same kind, and compilers may complain. We may convert them, but overflow may occur. + if (maxfilt > MAXHISTMEM / unit_memo) then + maxfilt = int(MAXHISTMEM / unit_memo, kind(maxfilt)) ! Integer division. + end if + maxfilt = min(maxfun, max(MIN_MAXFILT, maxfilt)) + if (is_constrained_loc) then + if (maxfilt_in <= 0) then + call warning(solver, 'Invalid MAXFILT: '//num2str(maxfilt_in)// & + & '; it should be a positive integer; it is set to '//num2str(maxfilt)) + elseif (maxfilt_in < min(maxfun, MIN_MAXFILT)) then + call warning(solver, 'MAXFILT = '//num2str(maxfilt_in)//' is too small; it is set to '//num2str(maxfilt)) + elseif (maxfilt < min(maxfilt_in, maxfun)) then + call warning(solver, 'MAXFILT is reduced from '//num2str(maxfilt_in)//' to '//num2str(maxfilt)//' due to memory limit') + end if + end if +end if + +! Validate ETA1 and ETA2 +if (.not. (eta1 >= 0 .and. eta1 < 1)) then ! ETA1 = NaN falls into this case. + eta1_in = eta1 + ! Take ETA2 into account if it has a valid value. + if (eta2 >= 0 .and. eta2 < 1) then + eta1 = eta2 / 7.0_RP + else + eta1 = ETA1_DFT + end if + call warning(solver, 'Invalid ETA1: '//num2str(eta1_in)// & + & '; it should be in the interval [0, 1) and not more than ETA2 = '//num2str(eta2)//'; it is set to '//num2str(eta1)) +end if + +if (.not. (eta2 >= eta1 .and. eta2 < 1)) then ! ETA2 = NaN falls into this case. + eta2_in = eta2 + ! Take ETA1 into account if it has a valid value. + if (eta1 >= 0 .and. eta1 < 1) then + eta2 = (eta1 + TWO) / 3.0_RP + else + eta2 = ETA2_DFT + end if + call warning(solver, 'Invalid ETA2: '//num2str(eta2_in)// & + & '; it should be in the interval [0, 1) and not less than ETA1 = '//num2str(eta1)//'; it is set to '//num2str(eta2)) +end if + +! The following revision may update ETA1 slightly. It prevents ETA1 > ETA2 due to rounding +! errors, which would not be accepted by the solvers. +eta1 = min(eta1, eta2) + +! Validate GAMMA1 and GAMMA2 +if (.not. (gamma1 > 0 .and. gamma1 < 1)) then ! GAMMA1 = NaN falls into this case. + gamma1_in = gamma1 + gamma1 = GAMMA1_DFT + call warning(solver, 'Invalid GAMMA1: '//num2str(gamma1_in)// & + & '; it should in the interval (0, 1); it is set to '//num2str(gamma1)) +end if + +if (.not. (is_finite(gamma2) .and. gamma2 >= 1)) then ! GAMMA2 = NaN falls into this case. + gamma2_in = gamma2 + gamma2 = GAMMA2_DFT + call warning(solver, 'Invalid GAMMA2: '//num2str(gamma2_in)// & + & '; it should be a real number not less than 1; it is set to '//num2str(gamma2)) +end if + +! Validate RHOBEG and RHOEND + +rhobeg_in = rhobeg +rhoend_in = rhoend + +! Revise the default values for RHOBEG/RHOEND according to the solver. +if (lower(solver) == 'bobyqa') then + rhobeg_default = max(EPS, min(RHOBEG_DFT, minval(xu - xl) / 4.0_RP)) + rhoend_default = max(EPS, min((RHOEND_DFT / RHOBEG_DFT) * rhobeg_default, RHOEND_DFT)) +else + rhobeg_default = RHOBEG_DFT + rhoend_default = RHOEND_DFT +end if + +if (lower(solver) == 'bobyqa') then + ! Do NOT merge the IF below into the ELSEIF above! Otherwise, XU and XL may be accessed even if + ! the solver is not BOBYQA, because the logical evaluation is not short-circuit. + if (rhobeg > minval(xu - xl) / TWO) then + ! Do NOT make this revision if RHOBEG not positive or not finite, because otherwise RHOBEG + ! will get a huge value when XU or XL contains huge values that indicate unbounded variables. + rhobeg = minval(xu - xl) / 4.0_RP ! Here, we do not take RHOBEG_DEFAULT. + call warning(solver, 'Invalid RHOBEG: '//num2str(rhobeg_in)// & + & '; '//solver//' requires 0 < RHOBEG <= MINVAL(XU-XL)/2 = '//num2str(minval(xu - xl) / 2.0_RP)// & + & '; it is set to '//num2str(rhobeg)) + end if +end if + +if (.not. (is_finite(rhobeg) .and. rhobeg > 0)) then ! RHOBEG = NaN falls into this case. + ! Take RHOEND into account if it has a valid value. We do not do this if the solver is BOBYQA, + ! which requires that RHOBEG <= (XU-XL)/2. + if (is_finite(rhoend) .and. rhoend > 0 .and. lower(solver) /= 'bobyqa') then + rhobeg = max(TEN * rhoend, rhobeg_default) + else + rhobeg = rhobeg_default + end if + call warning(solver, 'Invalid RHOBEG: '//num2str(rhobeg_in)// & + & '; it should be a positive number; it is set to '//num2str(rhobeg)) +end if + +if (.not. (is_finite(rhoend) .and. rhoend >= 0 .and. rhoend <= rhobeg)) then ! RHOEND = NaN falls into this case. + rhoend = max(EPS, min((RHOEND_DFT / RHOBEG_DFT) * rhobeg, rhoend_default)) + call warning(solver, 'Invalid RHOEND: '//num2str(rhoend_in)// & + & '; we should have '//num2str(rhobeg)//' = RHOBEG >= RHOEND >= 0; it is set to '//num2str(rhoend)) +end if + +! For BOBYQA, revise X0 or RHOBEG so that the distance between X0 and the inactive bounds is at +! least RHOBEG. If HONOUR_X0 == FALSE, revise X0 if needed; then revise RHOBEG if needed. +! N.B.: We should do the same for LINCOA and COBYLA if we make them respect the bounds in the future. +! !if (lower(solver) == 'bobyqa' .or. lower(solver) == 'lincoa' .or. lower(solver) == 'cobyla') then +if (lower(solver) == 'bobyqa') then + ! Revise X0 if allowed and needed. + if (.not. honour_x0) then + x0_in = x0 ! Recorded to see whether X0 is really revised. + ! N.B.: The following revision is valid only if XL <= X0 <= XU and RHOBEG <= MINVAL(XU-XL)/2, + ! which should hold at this point due to the revision of RHOBEG and moderation of X0. + ! The cases below are mutually exclusive in precise arithmetic as MINVAL(XU-XL) >= 2*RHOBEG. + where (x0 <= xl + HALF * rhobeg) + x0 = xl + elsewhere(x0 < xl + rhobeg) + x0 = xl + rhobeg + end where + where (x0 >= xu - HALF * rhobeg) + x0 = xu + elsewhere(x0 > xu - rhobeg) + x0 = xu - rhobeg + end where + !!MATLAB code: + !!lbx = (x0 <= xl + 0.5 * rhobeg); + !!lbx_plus = (x0 > xl + 0.5 * rhobeg .and. x0 < xl + rhobeg); + !!ubx = (x0 >= xu - 0.5 * rhobeg); + !!ubx_minus = (x0 < xu - 0.5 * rhobeg .and. x0 > xu - rhobeg); + !!x0(lbx) = xl(lbx); + !!x0(lbx_plus) = xl(lbx_plus) + rhobeg; + !!x0(ubx) = xu(ubx); + !!x0(ubx_minus) = xu(ubx_minus) - rhobeg; + + if (any(abs(x0_in - x0) > 0)) then + call warning(solver, 'X0 is revised so that the distance between X0 and the inactive bounds is at least RHOBEG = '// & + & num2str(rhobeg)//'; revise RHOBEG or set HONOUR_X0 to .TRUE. if you prefer to keep X0 unchanged') + end if + end if + + ! Revise RHOBEG if needed. + ! N.B.: If X0 has been revised above (i.e., HONOUR_X0 is FALSE), then the following revision + ! is unnecessary in precise arithmetic. However, it may still be needed due to rounding errors. + lbx = (is_finite(xl) .and. x0 - xl <= EPS * max(ONE, abs(xl))) ! X0 essentially equals XL + ubx = (is_finite(xu) .and. x0 - xu >= -EPS * max(ONE, abs(xu))) ! X0 essentially equals XU + x0(trueloc(lbx)) = xl(trueloc(lbx)) + x0(trueloc(ubx)) = xu(trueloc(ubx)) + rhobeg = max(EPS, minval([rhobeg, x0(falseloc(lbx)) - xl(falseloc(lbx)), xu(falseloc(ubx)) - x0(falseloc(ubx))])) + if (rhobeg_in - rhobeg > EPS * max(ONE, rhobeg_in)) then + rhoend = max(EPS, min((rhoend / rhobeg_in) * rhobeg, rhoend)) ! We do not revise RHOEND unless RHOBEG is truly revised. + if (has_rhobeg) then + call warning(solver, 'RHOBEG is revised from '//num2str(rhobeg_in)//' to '//num2str(rhobeg)// & + & ' and RHOEND from '//num2str(rhoend_in)//' to '//num2str(rhoend)// & + & ' so that the distance between X0 and the inactive bounds is at least RHOBEG') + end if + end if +end if + +! The following revision may update RHOBEG and RHOEND slightly. It particularly prevents +! RHOEND > RHOBEG due to rounding errors, which would not be accepted by the solvers. +rhobeg = max(rhobeg, EPS) +rhoend = min(max(rhoend, EPS), rhobeg) + +! Validate CTOL (it can be 0) +if (present(ctol)) then + if (.not. (ctol >= 0)) then ! CTOL = NaN falls into this case. + ctol_in = ctol + ctol = CTOL_DFT + if (is_constrained_loc) then + call warning(solver, 'Invalid CTOL: '//num2str(ctol_in)// & + & '; it should be a nonnegative number; it is set to '//num2str(ctol)) + end if + end if +end if + +! Validate CWEIGHT (it can be +Inf) +if (present(cweight)) then + if (.not. (cweight >= 0)) then ! CWEIGHT = NaN falls into this case. + cweight_in = cweight + cweight = CWEIGHT_DFT + if (is_constrained_loc) then + call warning(solver, 'Invalid CWEIGHT: '//num2str(cweight_in)// & + & '; it should be a nonnegative number; it is set to '//num2str(cweight)) + end if + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call validate(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', solver) + call validate(maxhist >= 0 .and. maxhist <= maxfun, '0 <= MAXHIST <= MAXFUN', solver) + call validate(maxfun >= min_maxfun, 'MAXFUN >= MIN_MAXFUN', solver) + if (present(npt)) then + call validate(npt >= n + 2 .and. npt < maxfun .and. 2 * int(npt) <= int(n + 2) * int(n + 1), & + & 'N+2 <= NPT < MAXFUN and 2*NPT <= (N+1)(N+2)', solver) + end if + if (present(maxfilt)) then + call validate(maxfilt >= min(MIN_MAXFILT, maxfun) .and. maxfilt <= maxfun, & + & 'MIN(MIN_MAXFILT, MAXFUN) <= MAXFILT <= MAXFUN', solver) + end if + call validate(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', solver) + call validate(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', solver) + call validate(rhobeg >= rhoend .and. rhoend > 0, 'RHOBEG >= RHOEND > 0', solver) + if (lower(solver) == 'bobyqa') then + call validate(all(rhobeg <= (xu - xl) / TWO), 'RHOBEG <= MINVAL(XU-XL)/2', solver) + call validate(all(is_finite(x0)), 'X0 is finite', solver) + call validate(all(x0 >= xl .and. (x0 <= xl .or. x0 - xl >= rhobeg)), 'X0 == XL or X0 - XL >= RHOBEG', solver) + call validate(all(x0 <= xu .and. (x0 >= xu .or. xu - x0 >= rhobeg)), 'X0 == XU or XU - X0 >= RHOBEG', solver) + end if + if (present(ctol)) then + call validate(ctol >= 0, 'CTOL >= 0', solver) + end if +end if + +end subroutine preproc + + +end module preproc_mod diff --git a/examples/fortran/prima/native/common/ratio.f90 b/examples/fortran/prima/native/common/ratio.f90 new file mode 100644 index 000000000..ac8bc55cf --- /dev/null +++ b/examples/fortran/prima/native/common/ratio.f90 @@ -0,0 +1,83 @@ +module ratio_mod +!--------------------------------------------------------------------------------------------------! +! This module calculates the reduction ratio for trust-region methods. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: September 2021 +! +! Last Modified: Sunday, December 11, 2022 AM01:29:35 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: redrat + + +contains + + +function redrat(ared, pred, rshrink) result(ratio) +!--------------------------------------------------------------------------------------------------! +! This function evaluates the reduction ratio of a trust-region step, handling Inf/NaN properly. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ONE, HALF, REALMAX, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_neginf +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: ared +real(RP), intent(in) :: pred +real(RP), intent(in) :: rshrink ! When RATIO <= RSHRINK, DELTA will be shrunk. + +! Outputs +real(RP) :: ratio + +! Local variables +character(len=*), parameter :: srname = 'REDRAT' + +! Preconditions +if (DEBUGGING) then + call assert(rshrink >= 0, 'RSHRINK >= 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (is_nan(ared)) then + ! This should not happen in unconstrained problems due to the moderated extreme barrier. + ratio = -REALMAX +elseif (is_nan(pred) .or. pred <= 0) then + ! The trust-region subproblem solver fails in this rare case. Instead of terminating as Powell's + ! original code does, we set RATIO as follows so that the solver may continue to progress. + if (ared > 0) then + ! The trial point will be accepted, but the trust-region radius will be shrunk if RSHRINK>0. + ratio = HALF * rshrink + else + ! Set ratio to a large negative number to signify a bad trust-region step, so that the + ! solver will check whether to take a geometry step or reduce RHO. + ratio = -REALMAX + end if +elseif (is_posinf(pred) .and. is_posinf(ared)) then + ratio = ONE ! ARED/PRED = NaN if calculated directly. +elseif (is_posinf(pred) .and. is_neginf(ared)) then + ratio = -REALMAX ! ARED/PRED = NaN if calculated directly. +else + ratio = ared / pred +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(.not. is_nan(ratio), 'RATIO is not NaN', srname) +end if + +end function redrat + + +end module ratio_mod diff --git a/examples/fortran/prima/native/common/redrho.f90 b/examples/fortran/prima/native/common/redrho.f90 new file mode 100644 index 000000000..0a89cf29e --- /dev/null +++ b/examples/fortran/prima/native/common/redrho.f90 @@ -0,0 +1,71 @@ +module redrho_mod +!--------------------------------------------------------------------------------------------------! +! This module provides a function that calculates RHO when it needs to be reduced. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: September 2021 +! +! Last Modified: Monday, November 06, 2023 PM07:45:58 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: redrho + + +contains + + +function redrho(rho_in, rhoend) result(rho) +!--------------------------------------------------------------------------------------------------! +! This function calculates RHO when it needs to be reduced. +! The scheme is shared by UOBYQA, NEWUOA, BOBYQA, LINCOA. For COBYLA, Powell's code reduces RHO by +! `RHO = HALF * RHO; IF (RHO <= 1.5_RP * RHOEND) RHO = RHOEND`, as specified in (11) of the COBYLA +! paper. However, this scheme seems to work better, especially after we introduce DELTA. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, TENTH, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: rho_in +real(RP), intent(in) :: rhoend + +! Outputs +real(RP) :: rho + +real(RP) :: rho_ratio +character(len=*), parameter :: srname = 'REDRHO' + +! Preconditions +if (DEBUGGING) then + call assert(rho_in > rhoend .and. rhoend > 0, 'RHO_IN > RHOEND > 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +rho_ratio = rho_in / rhoend + +if (rho_ratio > 250.0_RP) then + rho = TENTH * rho_in +else if (rho_ratio <= 16.0_RP) then + rho = rhoend +else + rho = sqrt(rho_ratio) * rhoend !rho = sqrt(rho_in * rhoend) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(rho_in > rho .and. rho >= rhoend, 'RHO_IN > RHO >= RHOEND', srname) +end if +end function redrho + + +end module redrho_mod diff --git a/examples/fortran/prima/native/common/selectx.f90 b/examples/fortran/prima/native/common/selectx.f90 new file mode 100644 index 000000000..6a5f7f9bc --- /dev/null +++ b/examples/fortran/prima/native/common/selectx.f90 @@ -0,0 +1,530 @@ +module selectx_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines that ensure the returned X is optimal among all the calculated +! points in the sense that no other point achieves both lower function value and lower constraint +! violation at the same time. The module is needed only in the constrained case. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: September 2021 +! +! Last Modified: Saturday, March 02, 2024 AM12:42:28 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: savefilt, selectx, isbetter + +interface isbetter + module procedure isbetter10, isbetter01 +end interface isbetter + +contains + + +subroutine savefilt(cstrv, ctol, cweight, f, x, nfilt, cfilt, ffilt, xfilt, constr, confilt) +!--------------------------------------------------------------------------------------------------! +! This subroutine saves X, F, and CSTRV in XFILT, FFILT, and CFILT (and CONSTR in CONFILT if they +! are present), unless a vector in XFILT(:, 1:NFILT) is better than X. If X is better than some +! vectors in XFILT(:, 1:NFILT), then these vectors will be removed. If X is not better than any of X +! FILT(:, 1:NFILT) but NFILT=MAXFILT, then we remove a column from XFILT according to the merit +! function PHI = FFILT + CWEIGHT * MAX(CFILT - CTOL, ZERO). +! N.B.: +! 1. Only XFILT(:, 1:NFILT) and FFILT(:, 1:NFILT) etc contains valid information, while +! XFILT(:, NFILT+1:MAXFILT) and FFILT(:, NFILT+1:MAXFILT) etc are not initialized yet. +! 2. We decide whether an X is better than another by the ISBETTER function. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +use, non_intrinsic :: linalg_mod, only : trueloc + +implicit none + +! Inputs +real(RP), intent(in) :: cstrv +real(RP), intent(in) :: ctol +real(RP), intent(in) :: cweight +real(RP), intent(in) :: f +real(RP), intent(in) :: x(:) ! N +real(RP), intent(in), optional :: constr(:) ! M + +! In-outputs +integer(IK), intent(inout) :: nfilt +real(RP), intent(inout) :: cfilt(:) ! MAXFILT +real(RP), intent(inout) :: ffilt(:) ! MAXFILT +real(RP), intent(inout) :: xfilt(:, :) ! (N, MAXFILT) +real(RP), intent(inout), optional :: confilt(:, :) ! (M, MAXFILT) + +! Local variables +character(len=*), parameter :: srname = 'SAVEFILT' +integer(IK) :: index_to_keep(size(ffilt)) +integer(IK) :: kworst +integer(IK) :: m +integer(IK) :: maxfilt +integer(IK) :: n +logical :: keep(nfilt) +real(RP) :: cfilt_shifted(size(ffilt)) +real(RP) :: cref +real(RP) :: fref +real(RP) :: phi(size(ffilt)) +real(RP) :: phimax + +! Sizes +if (present(constr)) then + m = int(size(constr), kind(m)) +else + m = 0 +end if +n = int(size(x), kind(n)) +maxfilt = int(size(ffilt), kind(maxfilt)) + +! Preconditions +if (DEBUGGING) then + ! Check the size of X. + call assert(n >= 1, 'N >= 1', srname) + ! Check CWEIGHT and CTOL + call assert(cweight >= 0, 'CWEIGHT >= 0', srname) + call assert(ctol >= 0, 'CTOL >= 0', srname) + ! Check NFILT + call assert(nfilt >= 0 .and. nfilt <= maxfilt, '0 <= NFILT <= MAXFILT', srname) + ! Check the sizes of XFILT, FFILT, CFILT. + call assert(maxfilt >= 1, 'MAXFILT >= 1', srname) + call assert(size(xfilt, 1) == n .and. size(xfilt, 2) == maxfilt, 'SIZE(XFILT) == [N, MAXFILT]', srname) + call assert(size(cfilt) == maxfilt, 'SIZE(CFILT) == MAXFILT', srname) + ! Check the values of XFILT, FFILT, CFILT. + call assert(.not. any(is_nan(xfilt(:, 1:nfilt))), 'XFILT does not contain NaN', srname) + call assert(.not. any(is_nan(ffilt(1:nfilt)) .or. is_posinf(ffilt(1:nfilt))), & + & 'FFILT does not contain NaN/+Inf', srname) + call assert(.not. any(cfilt(1:nfilt) < 0 .or. is_nan(cfilt(1:nfilt)) .or. is_posinf(cfilt(1:nfilt))), & + & 'CFILT does not contain nonnegative values of NaN/+Inf', srname) + ! Check the values of X, F, CSTRV. + ! X does not contain NaN if X0 does not and the trust-region/geometry steps are proper. + call assert(.not. any(is_nan(x)), 'X does not contain NaN', srname) + ! F cannot be NaN/+Inf due to the moderated extreme barrier. + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + ! CSTRV cannot be NaN/+Inf due to the moderated extreme barrier. + call assert(.not. (cstrv < 0 .or. is_nan(cstrv) .or. is_posinf(cstrv)), 'CSTRV is nonnegative and not NaN/+Inf', srname) + ! Check CONSTR and CONFILT. + call assert(present(constr) .eqv. present(confilt), 'CONSTR and CONFILT are both present or both absent', srname) + if (present(constr)) then + ! CONSTR cannot contain NaN/+Inf due to the moderated extreme barrier. + call assert(.not. any(is_nan(constr) .or. is_posinf(constr)), 'CONSTR does not contain NaN/+Inf', srname) + call assert(size(confilt, 1) == m .and. size(confilt, 2) == maxfilt, 'SIZE(CONFILT) == [M, MAXFILT]', srname) + call assert(.not. any(is_nan(confilt(:, 1:nfilt)) .or. is_posinf(confilt(:, 1:nfilt))), & + & 'CONFILT does not contain NaN/+Inf', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +! Return immediately if any column of XFILT is better than X. Note that ISBETTER checks "strictly +! better", handling NaN/Inf properly, but we need "non-strictly better" here, allowing equality. +! This is why we need to supplement ISBETTER with (FFILT <= F .AND. CFILT <= CSTRV). +if (any(isbetter(ffilt(1:nfilt), cfilt(1:nfilt), f, cstrv, ctol)) .or. & + & any(ffilt(1:nfilt) <= f .and. cfilt(1:nfilt) <= cstrv)) then + return +end if + +! Decide which columns of XFILT to keep. +keep = (.not. isbetter(f, cstrv, ffilt(1:nfilt), cfilt(1:nfilt), ctol)) + +! If NFILT == MAXFILT and X is not better than any column of XFILT, then we remove the worst column +! of XFILT according to the merit function PHI = FFILT + CWEIGHT * MAX(CFILT - CTOL, ZERO). +if (count(keep) == maxfilt) then ! In this case, NFILT = SIZE(KEEP) = COUNT(KEEP) = MAXFILT > 0. + cfilt_shifted = max(cfilt - ctol, ZERO) + if (cweight <= 0) then + phi = ffilt + elseif (is_posinf(cweight)) then + phi = cfilt_shifted + ! We should not use CFILT here; if MAX(CFILT_SHIFTED) is attained at multiple indices, then + ! we will check FFILT to exhaust the remaining degree of freedom. + else + phi = max(ffilt, -REALMAX) + cweight * cfilt_shifted + ! MAX(FFILT, -REALMAX) makes sure that PHI will not contain NaN (unless there is a bug). + end if + ! We select X to maximize PHI. In case there are multiple maximizers, we take the one with the + ! largest CSTRV_SHIFTED; if there are more than one choices, we take the one with the largest F; + ! if there are several candidates, we take the one with the largest CSTRV; if the last comparison + ! still leads to more than one possibilities, then they are equally bad and we choose the first. + ! N.B.: + ! 1. This process is the opposite of selecting KOPT in SELECTX. + ! 2. In finite-precision arithmetic, PHI_1 == PHI_2 and CSTRV_SHIFTED_1 == CSTRV_SHIFTED_2 do + ! not ensure that F_1 == F_2! + phimax = maxval(phi) + cref = maxval(cfilt_shifted, mask=(phi >= phimax)) + fref = maxval(ffilt, mask=(cfilt_shifted >= cref)) + kworst = int(maxloc(cfilt, mask=(ffilt >= fref), dim=1), kind(kworst)) + !!MATLAB: cmax = max(cfilt(ffilt >= fref)); kworst = find(ffilt >= fref & ~(cfilt < cmax), 1,'first'); + if (kworst < 1 .or. kworst > size(keep)) then ! For security. Should not happen. + kworst = 1 + end if + keep(kworst) = .false. +end if + +nfilt = int(count(keep), kind(nfilt)) +index_to_keep(1:nfilt) = trueloc(keep) +xfilt(:, 1:nfilt) = xfilt(:, index_to_keep(1:nfilt)) +ffilt(1:nfilt) = ffilt(index_to_keep(1:nfilt)) +cfilt(1:nfilt) = cfilt(index_to_keep(1:nfilt)) +if (present(confilt) .and. present(constr)) then + confilt(:, 1:nfilt) = confilt(:, index_to_keep(1:nfilt)) +end if + +nfilt = nfilt + 1_IK +xfilt(:, nfilt) = x +ffilt(nfilt) = f +cfilt(nfilt) = cstrv +if (present(confilt) .and. present(constr)) then + confilt(:, nfilt) = constr +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + ! Check NFILT and the sizes of XFILT, FFILT, CFILT. + call assert(nfilt >= 1 .and. nfilt <= maxfilt, '1 <= NFILT <= MAXFILT', srname) + call assert(size(xfilt, 1) == n .and. size(xfilt, 2) == maxfilt, 'SIZE(XFILT) == [N, MAXFILT]', srname) + call assert(size(ffilt) == maxfilt, 'SIZE(FFILT) = MAXFILT', srname) + call assert(size(cfilt) == maxfilt, 'SIZE(CFILT) = MAXFILT', srname) + ! Check the values of XFILT, FFILT, CFILT. + call assert(.not. any(is_nan(xfilt(:, 1:nfilt))), 'XFILT does not contain NaN', srname) + call assert(.not. any(is_nan(ffilt(1:nfilt)) .or. is_posinf(ffilt(1:nfilt))), & + & 'FFILT does not contain NaN/+Inf', srname) + call assert(.not. any(cfilt(1:nfilt) < 0 .or. is_nan(cfilt(1:nfilt)) .or. is_posinf(cfilt(1:nfilt))), & + & 'CFILT does not contain nonnegative values of NaN/+Inf', srname) + ! Check that no point in the filter is better than X, and X is better than no point. + call assert(.not. any(isbetter(ffilt(1:nfilt), cfilt(1:nfilt), f, cstrv, ctol)), & + & 'No point in the filter is better than X', srname) + call assert(.not. any(isbetter(f, cstrv, ffilt(1:nfilt), cfilt(1:nfilt), ctol)), & + & 'X is better than no point in the filter', srname) + ! Check CONFILT. + if (present(confilt)) then + call assert(size(confilt, 1) == m .and. size(confilt, 2) == maxfilt, 'SIZE(CONFILT) == [M, MAXFILT]', srname) + call assert(.not. any(is_nan(confilt(:, 1:nfilt)) .or. is_posinf(confilt(:, 1:nfilt))), & + & 'CONFILT does not contain NaN/+Inf', srname) + end if +end if + +end subroutine savefilt + + +function selectx(fhist, chist, cweight, ctol) result(kopt) +!--------------------------------------------------------------------------------------------------! +! This subroutine selects X according to the FHIST and CHIST, which represents (a part of) history +! of F and CSTRV. Normally, FHIST and CHIST are not the full history but only a filter, e.g., FFILT +! and CFILT generated by SAVEFILT. However, we name them as FHIST and CHIST because the [F, CSTRV] +! in a filter should not dominate each other, but this subroutine does NOT assume such a property. +! N.B.: CTOL is the tolerance of constraint violation (CSTRV). A point is considered feasible if +! its constraint violation is at most CTOL. Note that CTOL is absolute, not relative. +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: consts_mod, only : IK, RP, EPS, REALMAX, FUNCMAX, CONSTRMAX, ZERO, TWO, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +use, non_intrinsic :: debug_mod, only : assert + +implicit none + +! Inputs +real(RP), intent(in) :: cweight +real(RP), intent(in) :: chist(:) +real(RP), intent(in) :: ctol +real(RP), intent(in) :: fhist(:) + +! Outputs +integer(IK) :: kopt + +! Local variables +character(len=*), parameter :: srname = 'SELECTX' +integer(IK) :: nhist +real(RP) :: chist_shifted(size(fhist)) +real(RP) :: cmin +real(RP) :: cref +real(RP) :: fref +real(RP) :: phi(size(fhist)) +real(RP) :: phimin + +! Sizes +nhist = int(size(fhist), IK) + +! Preconditions +if (DEBUGGING) then + call assert(nhist >= 1, 'SIZE(FHIST) >= 1', srname) + call assert(size(chist) == nhist, 'SIZE(FHIST) == SIZE(CHIST)', srname) + call assert(.not. any(is_nan(fhist) .or. is_posinf(fhist)), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(chist < 0 .or. is_nan(chist) .or. is_posinf(chist)), & + & 'CHIST does not contain nonnegative values or NaN/+Inf', srname) + call assert(cweight >= 0, 'CWEIGHT >= 0', srname) + call assert(ctol >= 0, 'CTOL >= 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! We select X among the points with F < FREF and CSTRV < CREF. +! Do NOT use F <= FREF, because F == FREF (FUNCMAX or REALMAX) may mean F == INF in practice! +if (any(fhist < FUNCMAX .and. chist < CONSTRMAX)) then + fref = FUNCMAX + cref = CONSTRMAX +elseif (any(fhist < REALMAX .and. chist < CONSTRMAX)) then + fref = REALMAX + cref = CONSTRMAX +elseif (any(fhist < FUNCMAX .and. chist < REALMAX)) then + fref = FUNCMAX + cref = REALMAX +else + fref = REALMAX + cref = REALMAX +end if + +if (.not. any(fhist < fref .and. chist < cref)) then + kopt = nhist +else + ! Shift the constraint violations by CTOL, so that CSTRV <= CTOL is regarded as no violation. + chist_shifted = max(chist - ctol, ZERO) + ! CMIN is the minimal shifted constraint violation attained in the history. + cmin = minval(chist_shifted, mask=(fhist < fref)) + ! We consider only the points whose shifted constraint violations are at most the CREF below. + ! N.B.: Without taking MAX(EPS, .), CREF would be 0 if CMIN = 0. In that case, asking for + ! CSTRV_SHIFTED < CREF would be WRONG! + cref = max(EPS, TWO * cmin) + ! We use the following PHI as our merit function to select X. + if (cweight <= 0) then + phi = fhist + elseif (is_posinf(cweight)) then + phi = chist_shifted + ! We should not use CHIST here; if MIN(CHIST_SHIFTED) is attained at multiple indices, then + ! we will check FHIST to exhaust the remaining degree of freedom. + else + phi = max(fhist, -REALMAX) + cweight * chist_shifted + ! MAX(FHIST, -REALMAX) makes sure that PHI will not contain NaN (unless there is a bug). + end if + ! We select X to minimize PHI subject to F < FREF and CSTRV_SHIFTED <= CREF (see the comments + ! above for the reason of taking "<" and "<=" in these two constraints). In case there are + ! multiple minimizers, we take the one with the least CSTRV_SHIFTED; if there are more than one + ! choices, we take the one with the least F; if there are several candidates, we take the one + ! with the least CSTRV; if the last comparison still leads to more than one possibilities, then + ! they are equally good and we choose the first. + ! N.B.: + ! 1. This process is the opposite of selecting KWORST in SAVEFILT. + ! 2. In finite-precision arithmetic, PHI_1 == PHI_2 and CSTRV_SHIFTED_1 == CSTRV_SHIFTED_2 do + ! not ensure that F_1 == F_2! + phimin = minval(phi, mask=(fhist < fref .and. chist_shifted <= cref)) + cref = minval(chist_shifted, mask=(fhist < fref .and. phi <= phimin)) + fref = minval(fhist, mask=(chist_shifted <= cref)) + kopt = int(minloc(chist, mask=(fhist <= fref), dim=1), kind(kopt)) + !!MATLAB: cmin = min(chist(fhist <= fref)); kopt = find(fhist <= fref & ~(chist > cmin), 1,'first'); +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(kopt >= 1 .and. kopt <= nhist, '1 <= KOPT <= SIZE(FHIST)', srname) + call assert(.not. any(isbetter(fhist(1:nhist), chist(1:nhist), fhist(kopt), chist(kopt), ctol)), & + & 'No point in the history is better than X', srname) +end if + +end function selectx + + +function isbetter00(f1, c1, f2, c2, ctol) result(is_better) +!--------------------------------------------------------------------------------------------------! +! This function compares whether FC1 = (F1, C1) is (strictly) better than FC2 = (F2, C2), which +! basically means that (F1 < F2 and C1 <= C2) or (F1 <= F2 and C1 < C2). +! It takes care of the cases where some of these values are NaN or Inf, even though some cases +! should never happen due to the moderated extreme barrier. +! At return, BETTER = TRUE if and only if (F1, C1) is better than (F2, C2). +! Here, C means constraint violation, which is a nonnegative number. +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: consts_mod, only : RP, TEN, EPS, CONSTRMAX, REALMAX, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +use, non_intrinsic :: debug_mod, only : assert +implicit none + +! Inputs +real(RP), intent(in) :: f1 +real(RP), intent(in) :: c1 +real(RP), intent(in) :: f2 +real(RP), intent(in) :: c2 +real(RP), intent(in) :: ctol + +! Outputs +logical :: is_better + +! Local variables +character(len=*), parameter :: srname = 'ISBETTER' +real(RP) :: cref + +! Preconditions +if (DEBUGGING) then + call assert(.not. any(is_nan([f1, c1]) .or. is_posinf([f2, c2])), 'FC1 does not contain NaN/+Inf', srname) + call assert(.not. any(is_nan([f2, c2]) .or. is_posinf([f2, c2])), 'FC2 does not contain NaN/+Inf', srname) + call assert(c1 >= 0 .and. c2 >= 0, 'C1 >= 0, C2 >= 0', srname) + call assert(ctol >= 0, 'CTOL >= 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +is_better = .false. +! Even though NaN/+Inf should not occur in FC1 or FC2 due to the moderated extreme barrier, for +! security and robustness, the code below does not make this assumption. +is_better = is_better .or. (any(is_nan([f2, c2]) .or. is_posinf([f2, c2])) .and. .not. & + & any(is_nan([f1, c1]) .or. is_posinf([f1, c1]))) +is_better = is_better .or. (f1 < f2 .and. c1 <= c2) +is_better = is_better .or. (f1 <= f2 .and. c1 < c2) +! If C1 <= CTOL and C2 is significantly larger/worse than CTOL, i.e., C2 > MAX(CTOL, CREF), +! then FC1 is better than FC2 as long as F1 < REALMAX. Normally CREF >= CTOL so MAX(CTOL, CREF) +! is indeed CREF. However, this may not be true if CTOL > 1E-1*CONSTRMAX. +cref = TEN * max(EPS, min(ctol, 1.0E-2_RP * CONSTRMAX)) ! The MIN avoids overflow. +is_better = is_better .or. (f1 < REALMAX .and. c1 <= ctol .and. (c2 > max(ctol, cref) .or. is_nan(c2))) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + ! Even though NaN/+Inf should not occur in FC1 due to moderated extreme barrier, for security + ! and robustness, the code below does not make this assumption. + call assert(.not. (is_better .and. any(is_nan([f1, c1]) .or. is_posinf([f1, c1]))), & + & 'IS_BETTER cannot be true if [F1, C1] contains NaN/+Inf', srname) + call assert(is_better .or. any(is_nan([f1, c1]) .or. is_posinf([f1, c1])) .or. & + & .not. any(is_nan([f2, c2]) .or. is_posinf([f2, c2])), & + & 'if [F2, C2] contains NaN/+Inf, then either IS_BETTER is true or [F1, C1] contains NaN/+Inf', srname) + call assert(.not. (is_better .and. f1 >= f2 .and. c1 >= c2), & + & '[F1, C1] >= [F2, C2] and IS_BETTER cannot be both true', srname) + call assert(is_better .or. .not. (f1 <= f2 .and. c1 < c2), & + & 'if [F1, C1] <= [F2, C2] but not equal, then IS_BETTER must be true', srname) + call assert(is_better .or. .not. (f1 < f2 .and. c1 <= c2), & + & 'if [F1, C1] <= [F2, C2] but not equal, then IS_BETTER must be true', srname) +end if + +end function isbetter00 + + +function isbetter10(f1, c1, f2, c2, ctol) result(is_better) +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +use, non_intrinsic :: memory_mod, only : safealloc +implicit none + +! Inputs +real(RP), intent(in) :: f1(:) +real(RP), intent(in) :: c1(:) +real(RP), intent(in) :: f2 +real(RP), intent(in) :: c2 +real(RP), intent(in) :: ctol + +! Outputs +logical, allocatable :: is_better(:) + +! Local variables +character(len=*), parameter :: srname = 'ISBETTER10' +integer(IK) :: i +integer(IK) :: nfc + +! Sizes +nfc = int(size(f1), kind(nfc)) + +! Preconditions +if (DEBUGGING) then + call assert(nfc >= 0, 'NFC >= 0', srname) + call assert(size(f1) == size(c1), 'SIZE(F1) == SIZE(C1)', srname) + call assert(.not. any(is_nan(f1) .or. is_posinf(f1)), 'F1 does not contain NaN/+Inf', srname) + call assert(.not. any(is_nan(c1) .or. is_posinf(c1)), 'C1 does not contain NaN/+Inf', srname) + call assert(.not. (is_nan(f2) .or. is_posinf(f2)), 'F2 is not NaN/+Inf', srname) + call assert(.not. (is_nan(c2) .or. is_posinf(c2)), 'C2 is not NaN/+Inf', srname) + call assert(all(c1 >= 0) .and. c2 >= 0, 'C1 >= 0, C2 >= 0', srname) + call assert(ctol >= 0, 'CTOL >= 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +call safealloc(is_better, nfc) +is_better = [(isbetter00(f1(i), c1(i), f2, c2, ctol), i=1, nfc)] + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(is_better) == size(f1), 'SIZE(IS_BETTER) == SIZE(F1)', srname) +end if + +end function isbetter10 + + +function isbetter01(f1, c1, f2, c2, ctol) result(is_better) +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +use, non_intrinsic :: memory_mod, only : safealloc +implicit none + +! Inputs +real(RP), intent(in) :: f1 +real(RP), intent(in) :: c1 +real(RP), intent(in) :: f2(:) +real(RP), intent(in) :: c2(:) +real(RP), intent(in) :: ctol + +! Outputs +logical, allocatable :: is_better(:) + +! Local variables +character(len=*), parameter :: srname = 'ISBETTER01' +integer(IK) :: i +integer(IK) :: nfc + +! Sizes +nfc = int(size(f2), kind(nfc)) + +! Preconditions +if (DEBUGGING) then + call assert(nfc >= 0, 'NFC >= 0', srname) + call assert(.not. (is_nan(f1) .or. is_posinf(f1)), 'F1 is not NaN/+Inf', srname) + call assert(.not. (is_nan(c1) .or. is_posinf(c1)), 'C1 is not NaN/+Inf', srname) + call assert(size(f2) == size(c2), 'SIZE(F2) == SIZE(C2)', srname) + call assert(.not. any(is_nan(f2) .or. is_posinf(f2)), 'F2 does not contain NaN/+Inf', srname) + call assert(.not. any(is_nan(c2) .or. is_posinf(c2)), 'C2 does not contain NaN/+Inf', srname) + call assert(c1 >= 0 .and. all(c2 >= 0), 'C1 >= 0, C2 >= 0', srname) + call assert(ctol >= 0, 'CTOL >= 0', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +call safealloc(is_better, nfc) +is_better = [(isbetter00(f1, c1, f2(i), c2(i), ctol), i=1, nfc)] + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(is_better) == size(f2), 'SIZE(IS_BETTER) == SIZE(F2)', srname) +end if + +end function isbetter01 + + +end module selectx_mod diff --git a/examples/fortran/prima/native/common/shiftbase.f90 b/examples/fortran/prima/native/common/shiftbase.f90 new file mode 100644 index 000000000..dfc052f77 --- /dev/null +++ b/examples/fortran/prima/native/common/shiftbase.f90 @@ -0,0 +1,255 @@ +module shiftbase_mod +!--------------------------------------------------------------------------------------------------! +! This module contains a subroutine that shifts the base point from XBASE to XBASE + XPT. It is +! used in NEWUOA, BOBYQA, and LINCOA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the NEWUOA paper. +! +! Dedicated to late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2020 +! +! Last Modified: Thu 14 Aug 2025 07:35:47 AM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: shiftbase + +interface shiftbase + module procedure shiftbase_lfqint, shiftbase_qint +end interface shiftbase + +contains + + +subroutine shiftbase_lfqint(kopt, xbase, xpt, zmat, bmat, pq, hq, idz) +!--------------------------------------------------------------------------------------------------! +! This subroutine shifts the base point from XBASE to XBASE + XOPT and updates BMAT and HQ +! accordingly. PQ and ZMAT remain the same after the shifting. See Section 7 of the NEWUOA paper. +! N.B.: +! 1. In Powell's implementation of NEWUOA, the quadratic model is represented by [GQ, PQ, HQ], where +! GQ is the gradient of the quadratic model at XBASE. In that case, GQ should be updated by +! GQ = GQ + HESS_MUL(XOPT, XPT, PQ, HQ) in this subroutine, where PQ is the un-updated version. +! However, Powell implemented BOBYQA and LINCOA without GQ but with GOPT, which is the gradient at +! XBASE + XOPT. Note that GOPT remains unchanged when XBASE is shifted. In our implementation, +! NEWUOA also uses GOPT instead of GQ. +! 2. [IDZ, ZMAT] provides the factorization of Omega in (3.17) of the NEWUOA paper; in specific, +! Omega = sum_{i=1}^{NPT-N-1} s_i*ZMAT(:,i)*ZMAT(:,i)^T, s_i = -1 if i < IDZ, and si = 1 if i >= IDZ. +! In precise arithmetic, IDZ should be always 1; to cope with rounding errors, NEWUOA and LINCOA +! allow IDZ = -1 (see (4.18)--(4.20) of the NEWUOA paper); in BOBYQA, IDZ is always 1, and the +! rounding errors are handled by the RESCUE subroutine (Sec. 5 of the BOBYQA paper). +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, HALF, QUART, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : inprod, matprod, outprod, issymmetric + +implicit none + +! Inputs +integer(IK), intent(in) :: kopt +real(RP), intent(in) :: pq(:) ! PQ(NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) +integer(IK), intent(in), optional :: idz ! Absent in BOBYQA, being equivalent to IDZ = 1 + +! In-outputs +real(RP), intent(inout) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(inout) :: hq(:, :) ! HQ(N, N) +real(RP), intent(inout) :: xbase(:) ! XBASE(N) +real(RP), intent(inout) :: xpt(:, :) ! XPT(N, NPT) + +! Local variables +character(len=*), parameter :: srname = 'SHIFTBASE_LFQINT' +integer(IK) :: idz_loc +integer(IK) :: k +integer(IK) :: n +integer(IK) :: npt +real(RP) :: bymat(size(xbase), size(xbase)) +!real(RP) :: htol +real(RP) :: qxoptq +real(RP) :: sxpt(size(xpt, 2)) +real(RP) :: v(size(xbase)) +real(RP) :: vxopt(size(xbase), size(xbase)) +real(RP) :: xopt(size(xbase)) +real(RP) :: xoptsq +real(RP) :: xptxav(size(xpt, 1), size(xpt, 2)) +real(RP) :: ymat(size(xpt, 1), size(xpt, 2)) +real(RP) :: yzmat(size(xbase), size(zmat, 2)) +real(RP) :: yzmat_c(size(xbase), size(zmat, 2)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Read IDZ, which is absent from BOBYQA, being equivalent to IDZ = 1. +idz_loc = 1 +if (present(idz)) then + idz_loc = idz +end if + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(idz_loc >= 1 .and. idz_loc <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + ! The following test cannot be passed. + !htol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(10, MAXPOW10) * EPS)) ! Tolerance for error in H + !call assert(errh(idz_loc, bmat, zmat, xpt) <= htol, 'H = W^{-1} in (3.12) of the NEWUOA paper', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Read XOPT. +xopt = xpt(:, kopt) +xoptsq = inprod(xopt, xopt) + +! Update BMAT. See (7.11)--(7.12) of the NEWUOA paper and the elaborations around. +! XPTXAV corresponds to XPT - XAV in the NEWUOA paper, with XAV = (X0 + XOPT)/2. +xptxav = xpt - HALF * spread(xopt, dim=2, ncopies=npt) +!!MATLAB: xptxav = xpt - xopt/2 % xopt should be a column! Implicit expansion +!sxpt = matprod(xopt, xptxav) +sxpt = matprod(xopt, xpt) - HALF * xoptsq ! This one seems to work better numerically. + +! First, make the changes to BMAT that do not depend on ZMAT. +qxoptq = QUART * xoptsq +do k = 1, npt + ymat(:, k) = sxpt(k) * xptxav(:, k) + qxoptq * xopt +end do +!!MATLAB: ymat = xptxav .* sxpt + qxoptq * xopt % sxpt should be a row, xopt should be a column +!ymat(:, kopt) = HALF * xoptsq * xopt ! This makes no difference according to a test on 20220406 +bymat = matprod(bmat(:, 1:npt), transpose(ymat)) ! BMAT(:, 1:NPT) is not updated yet. +bmat(:, npt + 1:npt + n) = bmat(:, npt + 1:npt + n) + (bymat + transpose(bymat)) +! Then the revisions of BMAT that depend on ZMAT are calculated. +yzmat = matprod(ymat, zmat) +yzmat_c = yzmat +yzmat_c(:, 1:idz_loc - 1) = -yzmat(:, 1:idz_loc - 1) ! IDZ_LOC is usually small. So this assignment is cheap. +bmat(:, npt + 1:npt + n) = bmat(:, npt + 1:npt + n) + matprod(yzmat, transpose(yzmat_c)) +bmat(:, 1:npt) = bmat(:, 1:npt) + matprod(yzmat_c, transpose(zmat)) + +! Update the quadratic model. Note that PQ remains unchanged. For HQ, see (7.14) of the NEWUOA paper. +!v = matprod(xptxav, pq) ! Vector V in (7.14) of the NEWUOA paper +v = matprod(xpt, pq) - HALF * sum(pq) * xopt ! This one seems to work better numerically. +vxopt = outprod(v, xopt) !!MATLAB: vxopt = v * xopt'; % v and xopt should be both columns +hq = (vxopt + transpose(vxopt)) + hq !call r2update(hq, ONE, xopt, v) +!call symmetrize(hq) ! Do this if the update above does not ensure symmetry. + +! The following instructions complete the shift of XBASE. +xbase = xbase + xopt +xpt = xpt - spread(xopt, dim=2, ncopies=npt) +xpt(:, kopt) = ZERO +!!MATLAB: xpt = xpt - xopt; xpt(:, kopt) = 0; % xopt should be a column! Implicit expansion + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(abs(xpt(:, kopt)) <= 0), 'XPT(:, KOPT) == 0', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + ! The following test cannot be passed. + !call assert(errh(idz_loc, bmat, zmat, xpt) <= htol, 'H = W^{-1} in (3.12) of the NEWUOA paper', srname) +end if + +end subroutine shiftbase_lfqint + + +subroutine shiftbase_qint(kopt, pl, pq, xbase, xpt) +!--------------------------------------------------------------------------------------------------! +! This subroutine shifts the base point from XBASE to XBASE + XOPT, and make the corresponding +! changes to the gradients of the Lagrange functions and the quadratic model. See the discussion +! below (40) of the UOBYQA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : smat_mul_vec + +implicit none + +! Inputs +integer(IK), intent(in) :: kopt + +! In-outputs +real(RP), intent(inout) :: xbase(:) ! XBASE(N) +real(RP), intent(inout) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(inout) :: pl(:, :) ! PL(NPT-1, NPT) +real(RP), intent(inout) :: pq(:) ! PQ(NPT-1) + +! Local variables +character(len=*), parameter :: srname = 'SHIFTBASE_QINT' +integer(IK) :: k +integer(IK) :: n +integer(IK) :: npt +real(RP) :: xopt(size(xbase)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(npt == (n + 1) * (n + 2) / 2, 'NPT = (N+1)(N+2)/2', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(size(pl, 1) == npt - 1 .and. size(pl, 2) == npt, 'SIZE(PL) == [NPT-1, NPT]', srname) + call assert(size(pq) == npt - 1, 'SIZE(PQ) == NPT-1', srname) + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XOPT) == N, XOPT is finite', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt .and. all(is_finite(xpt)), & + & 'SIZE(XPT) == [N, NPT], XPT is finite', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Shift the base point from XBASE to XBASE + XOPT. +xopt = xpt(:, kopt) +xbase = xbase + xopt +xpt = xpt - spread(xopt, dim=2, ncopies=npt) +xpt(:, kopt) = ZERO + +! Update the gradient of the model +pq(1:n) = pq(1:n) + smat_mul_vec(pq(n + 1:npt - 1), xopt) + +! Update the gradient of the Lagrange functions. +do k = 1, npt + pl(1:n, k) = pl(1:n, k) + smat_mul_vec(pl(n + 1:npt - 1, k), xopt) +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(pl, 1) == npt - 1 .and. size(pl, 2) == npt, 'SIZE(PL) == [NPT-1, NPT]', srname) + call assert(size(pq) == npt - 1, 'SIZE(PQ) == NPT-1', srname) + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt .and. all(is_finite(xpt)), & + & 'SIZE(XPT) == [N, NPT], XPT is finite', srname) +end if + +end subroutine shiftbase_qint + + +end module shiftbase_mod diff --git a/examples/fortran/prima/native/common/string.f90 b/examples/fortran/prima/native/common/string.f90 new file mode 100644 index 000000000..1ee89be35 --- /dev/null +++ b/examples/fortran/prima/native/common/string.f90 @@ -0,0 +1,353 @@ +module string_mod +!--------------------------------------------------------------------------------------------------! +! This module provides some procedures for manipulating strings. +! +! Coded by Zaikun ZHANG (www.zhangzk.net). +! +! Started: September 2021 +! +! Last Modified: Sunday, March 31, 2024 PM09:44:38 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: lower, upper, strip, istr, num2str + +! MAX_NUM_STR_LEN is the maximum length of a string that is needed to represent a real or integer +! number. Assuming that such a number is represented by at most 128 bits, it is safe to set this +! maximum length to 128. We set this number to 1024 to be on the safe side. +integer, parameter :: MAX_NUM_STR_LEN = 1024 +! MAX_WIDTH is the maximum number of characters printed in each row when printing arrays. +integer, parameter :: MAX_WIDTH = 100 + +interface num2str + module procedure real2str_scalar, real2str_vector, int2str +end interface num2str + + +contains + + +pure function lower(x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function maps the characters of a string to the lower case, if applicable. +!--------------------------------------------------------------------------------------------------! + +implicit none + +character(len=*), intent(in) :: x +character(len=len(x)) :: y + +integer, parameter :: dist = ichar('A') - ichar('a') +integer :: i + +y = x +do i = 1, len(y) + if (y(i:i) >= 'A' .and. y(i:i) <= 'Z') then + y(i:i) = char(ichar(y(i:i)) - dist) + end if +end do +end function lower + + +pure function upper(x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function maps the characters of a string to the upper case, if applicable. +!--------------------------------------------------------------------------------------------------! + +implicit none + +character(len=*), intent(in) :: x +character(len=len(x)) :: y + +integer, parameter :: dist = ichar('A') - ichar('a') +integer :: i + +y = x +do i = 1, len(y) + if (y(i:i) >= 'a' .and. y(i:i) <= 'z') then + y(i:i) = char(ichar(y(i:i)) + dist) + end if +end do +end function upper + + +pure function strip(x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function removes the leading and trailing spaces of a string. +!--------------------------------------------------------------------------------------------------! + +implicit none + +character(len=*), intent(in) :: x +character(len=len(trim(adjustl(x)))) :: y + +y = trim(adjustl(x)) +end function strip + + +pure function istr(x) result(y) +!--------------------------------------------------------------------------------------------------! +! This function converts a string to an integer array. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK +implicit none +character(len=*), intent(in) :: x +integer(IK) :: y(len(x)) + +integer(IK) :: i + +y = [(int(ichar(x(i:i)), IK), i=1, int(len(x), IK))] + +end function istr + + +function real2str_scalar(x, ndgt, nexp) result(s) +!--------------------------------------------------------------------------------------------------! +! This function converts a real scalar to a string. Optionally, NDGT is the number of decimal +! digits to print, and NEXP is the number of digits in the exponent; they may be reduced if needed. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DP, IK, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert, validate +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan +implicit none +! Inputs +real(RP), intent(in) :: x +integer, intent(in), optional :: ndgt +integer, intent(in), optional :: nexp +! Outputs +character(len=:), allocatable :: s +! Local variables +character(len=*), parameter :: srname = 'REAL2STR_SCALAR' +character(len=:), allocatable :: sformat +character(len=MAX_NUM_STR_LEN) :: str +integer :: ndgt_loc ! The number of decimal digits to print +integer :: nexp_loc ! The number of digits in the exponent +integer :: wx ! The width of the printed X + +! Preconditions +if (DEBUGGING) then + if (present(ndgt)) then + call assert(ndgt >= 0 .and. 2 * ndgt <= MAX_NUM_STR_LEN - 5, & + & '0 <= NDGT <= '//int2str(floor(real(MAX_NUM_STR_LEN - 5) / 2.0, IK)), srname) + end if + if (present(nexp)) then + call assert(nexp >= 0 .and. 2 * nexp <= MAX_NUM_STR_LEN - 5, & + & '0 <= NEXP <= '//int2str(floor(real(MAX_NUM_STR_LEN - 5) / 2.0, IK)), srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +if (present(ndgt)) then + ndgt_loc = ndgt +else + ! By default, we print at most the same number of decimal digits as the double precision. + ndgt_loc = min(precision(x), precision(0.0_DP)) + 1 +end if +ndgt_loc = min(ndgt_loc, floor(real(MAX_NUM_STR_LEN - 5) / 2.0)) ! Safeguard +if (present(nexp)) then + nexp_loc = nexp +else + nexp_loc = ceiling(log10(real(range(x) + 0.1))) ! Use + 0.1 in case RANGE(X) = 10^k. +end if +nexp_loc = min(nexp_loc, floor(real(MAX_NUM_STR_LEN - 5) / 2.0)) + +if (.not. is_finite(x)) then + write (str, *) x + s = strip(str) ! Remove the leading and trailing spaces, if any. +else + wx = ndgt_loc + nexp_loc + 5 + call validate(wx <= MAX_NUM_STR_LEN, 'The width of the printed number is at most ' & + & //int2str(int(MAX_NUM_STR_LEN, IK)), srname) + sformat = '(1PE'//int2str(int(wx, IK))//'.'//int2str(int(ndgt_loc, IK))//'E'//int2str(int(nexp_loc, IK))//')' + write (str, sformat) x + s = trim(str) ! Remove the trailing spaces, but keep the leading ones, if any. +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(len(s) > 0 .and. len(s) <= MAX_NUM_STR_LEN, '0 < LEN(S) <= MAX_NUM_STR_LEN', srname) + call assert(is_nan(x) .eqv. is_nan(str2real(s)), 'IS_NAN(X) .EQV. IS_NAN(STR2REAL(S))', srname) + ! The assertions concerning the infiniteness of X may fail due to the limited precision of + ! printing. Thus we relax the assertions as below. + !call assert(is_posinf(x) .eqv. is_posinf(str2real(s)), 'IS_POSINF(X) .EQV. IS_POSINF(STR2REAL(S))', srname) + !call assert(is_neginf(x) .eqv. is_neginf(str2real(s)), 'IS_NEGINF(X) .EQV. IS_NEGINF(STR2REAL(S))', srname) + call assert(x >= REALMAX * (1.0 - 10.0**(-ndgt_loc)) .eqv. str2real(s) >= REALMAX * (1.0 - 10.0**(-ndgt_loc)), & + & 'IS_POSINF(X) .EQV. IS_POSINF(STR2REAL(S))', srname) + call assert(x <= -REALMAX * (1.0 - 10.0**(-ndgt_loc)) .eqv. str2real(s) <= -REALMAX * (1.0 - 10.0**(-ndgt_loc)), & + & 'IS_NEGINF(X) .EQV. IS_NEGINF(STR2REAL(S))', srname) + if (abs(x) < REALMAX) then + call assert(abs(x - str2real(s)) <= abs(x) * 10.0**(-ndgt_loc), 'STR2REAL(S) == X', srname) + end if +end if +end function real2str_scalar + +function real2str_vector(x, ndgt, nexp, nx) result(s) +!--------------------------------------------------------------------------------------------------! +! This function converts a real vector to a string. Optionally, NDGT is the number of decimal +! digits to print, NEXP is the number of digits in the exponent, and NX is the number of entries +! printed per row; they may be reduced if needed. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: memory_mod, only : safealloc +! Inputs +real(RP), intent(in) :: x(:) +integer, intent(in), optional :: ndgt +integer, intent(in), optional :: nexp +integer, intent(in), optional :: nx +! Outputs +character(len=:), allocatable :: s +! Local variables +character(len=*), parameter :: srname = 'REAL2STR_VECTOR' +character(len=2), parameter :: spaces = ' ' ! The spaces between two entries in a row +integer :: i +integer :: j +integer :: m ! The number of rows +integer :: n ! N = SIZE(X) +integer :: ndgt_loc ! The number of decimal digits to print +integer :: nexp_loc ! The number of digits in the exponent +integer :: nx_loc ! The number of entries printed per row +integer :: slen ! The length of the string +integer :: wx ! The width of each entry in X + +! Preconditions +if (DEBUGGING) then + if (present(ndgt)) then + call assert(ndgt >= 0 .and. 2 * ndgt <= MAX_NUM_STR_LEN - 5, & + & '0 <= NDGT <= '//int2str(floor(real(MAX_NUM_STR_LEN - 5) / 2.0, IK)), srname) + end if + if (present(nexp)) then + call assert(nexp >= 0 .and. 2 * nexp <= MAX_NUM_STR_LEN - 5, & + & '0 <= NEXP <= '//int2str(floor(real(MAX_NUM_STR_LEN - 5) / 2.0, IK)), srname) + end if + if (present(nx)) then + call assert(nx >= 1, 'NX >= 1', srname) + end if +end if + +!====================! +! Calculation starts ! +!====================! + +! Quick return if X is empty. +if (size(x) <= 0) then + s = '' + return +end if + +if (present(ndgt)) then + ndgt_loc = ndgt +else + ! By default, we print at most the same number of decimal digits as the double precision. + ndgt_loc = min(precision(x), precision(0.0_DP)) + 1 +end if +ndgt_loc = min(ndgt_loc, floor(real(MAX_NUM_STR_LEN - 5) / 2.0)) ! Safeguard + +if (present(nexp)) then + nexp_loc = nexp +else + nexp_loc = ceiling(log10(real(range(x)) + 0.1)) ! Use + 0.1 in case RANGE(X) = 10^k. +end if +nexp_loc = min(nexp_loc, floor(real(MAX_NUM_STR_LEN - 5) / 2.0)) + +wx = len(real2str_scalar(0.0_RP, ndgt, nexp)) +n = size(x) +if (present(nx)) then + nx_loc = max(1, min(nx, n)) +else + nx_loc = max(1, min(floor(real(MAX_WIDTH + len(spaces)) / (real(wx) + len(spaces))), size(x))) +end if + +! Calculate the length of the printed string S. +! N.B.: Here, SLEN should not be an INT16 integer, because a double-precision vector of length +! ~3500 would be printed as a string longer than 65536. On most modern platforms, the default +! integer kind is INT32, which is enough for printing double-precision vectors of size ~ 10^8, +! being sufficient for this project. +m = ceiling(real(n) / real(nx_loc)) ! The number of rows +slen = wx * n + len(spaces) * (n - 1) + (1 - len(spaces)) * (m - 1) +call safealloc(s, slen) + +j = 0 ! J is the index of the last up-to-date character in S. +do i = 1, n + s(j + 1:j + wx) = real2str_scalar(x(i), ndgt_loc, nexp_loc) + if (i == n) exit + j = j + wx + if (modulo(i, nx_loc) == 0) then + s(j + 1:j + 1) = new_line(s) + j = j + 1 + else + s(j + 1:j + len(spaces)) = spaces + j = j + len(spaces) + end if +end do + +!====================! +! Calculation ends ! +!====================! +end function real2str_vector + +function str2real(s) result(x) +!--------------------------------------------------------------------------------------------------! +! This function converts a string to a real scalar. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none +character(len=*), intent(in) :: s +real(RP) :: x +character(len=*), parameter :: srname = 'STR2REAL' +if (DEBUGGING) then + call assert(len(s) > 0, 'LEN(S) > 0', srname) +end if +read (s, *) x +end function str2real + + +function int2str(x) result(s) +!--------------------------------------------------------------------------------------------------! +! This function converts an integer scalar to a string. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none +integer(IK), intent(in) :: x +character(len=*), parameter :: srname = 'INT2STR' +character(len=:), allocatable :: s +character(len=MAX_NUM_STR_LEN) :: str +! In the following, 'I0' means to use the minimum number of digits needed to print. +! It should work also if we use * instead of I0. However, this sometimes lead to a segmentation +! fault on Windows Server 2022 with gcc/gfortran 13. +write (str, '(I0)') x +s = strip(str) +if (DEBUGGING) then + call assert(len(s) > 0 .and. len(s) <= MAX_NUM_STR_LEN, '0 < LEN(S) <= MAX_NUM_STR_LEN', srname) + call assert(str2int(s) == x, 'STR2INT(S) == X', srname) +end if +end function int2str + +function str2int(s) result(x) +!--------------------------------------------------------------------------------------------------! +! This function converts a string to an integer scalar. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none +character(len=*), intent(in) :: s +integer(IK) :: x +character(len=*), parameter :: srname = 'STR2INT' +if (DEBUGGING) then + call assert(len(s) > 0, 'LEN(S) > 0', srname) +end if +read (s, *) x +end function str2int + + +end module string_mod diff --git a/examples/fortran/prima/native/common/univar.f90 b/examples/fortran/prima/native/common/univar.f90 new file mode 100644 index 000000000..ad513c3d2 --- /dev/null +++ b/examples/fortran/prima/native/common/univar.f90 @@ -0,0 +1,306 @@ +module univar_mod +!--------------------------------------------------------------------------------------------------! +! This module implements functions that approximately optimizes univariate functions. They are used +! in NEWUOA (TRSAPP, BIGLAG, and BIGDEN) and BOBYQA (TRSBOX). +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code. +! +! Started: January 2021 +! +! Last Modified: Sunday, April 24, 2022 PM02:15:25 +! +! N.B.: +! 0. Here, the optimization is performed using only function values by sampling the objective +! function on a grid. Indeed, in NEWUOA and BOBYQA, the objective function optimized here is either +! a trigonometric function or a rational function. So derivatives can be used, but a simple grid +! search suffices because highly precise solutions are not necessary. +! 1. Both CIRCLE_MIN and CIRCLE_MAXABS require an input GRID_SIZE, the size of the grid used in +! the search. Powell chose GRID_SIZE = 50 in NEWUOA. MAGICALLY, this number works the best for +! NEWUOA in tests on CUTest problems. Larger (e.g., 60, 100) or smaller (e.g., 20, 40) values will +! worsen the performance of NEWUOA. Why? +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: circle_min, circle_maxabs, interval_max + +abstract interface + function FUNC_WITH_ARGS(x, args) result(f) + use, non_intrinsic :: consts_mod, only : RP + implicit none + real(RP), intent(in) :: x + real(RP), intent(in) :: args(:) + real(RP) :: f + end function FUNC_WITH_ARGS +end interface + + +contains + + +function circle_min(fun, args, grid_size) result(angle) +!--------------------------------------------------------------------------------------------------! +! This function seeks an approximate minimizer of a 2*PI-periodic function FUN(X, ARGS), where the +! scalar X is the decision variable, and ARGS is a given vector of parameters. It evaluates the +! function at an evenly distributed "grid" on [0, 2*PI], the number of grid points being GRID_SIZE. +! Then it takes the grid point with the least value of FUN, and improves the point by a step that +! minimizes the quadratic that interpolates FUN on this point and its two nearest neighbours. +! The objective function FUN can represent the parametrization of a function defined on the circle, +! which explains the name of this function. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TWO, HALF, PI, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : linspace +implicit none + +! Inputs +procedure(FUNC_WITH_ARGS) :: fun +real(RP), intent(in) :: args(:) +integer(IK), intent(in) :: grid_size + +! Outputs +real(RP) :: angle + +! Local variables +character(len=*), parameter :: srname = 'CIRCLE_MIN' +integer(IK) :: k +integer(IK) :: kopt +real(RP) :: agrid(grid_size + 1) +real(RP) :: fprev +real(RP) :: fnext +real(RP) :: fopt +real(RP) :: fgrid(grid_size) +real(RP) :: step +real(RP) :: unit_angle + +! Preconditions +if (DEBUGGING) then + call assert(grid_size >= 3, 'GRID_SIZE >= 3', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +agrid = linspace(ZERO, TWO * PI, grid_size + 1_IK) ! Size: GRID_SIZE+1; the last entry will be unused +fgrid = [(fun(agrid(k), args), k=1, grid_size)] +!!MATLAB: fgrid = arrayfun(@(angle) fun(angle, args), agrid(1:grid_size)); % Same shape as `agrid` + +if (all(is_nan(fgrid))) then + angle = ZERO + return +end if + +kopt = int(minloc(fgrid, mask=(.not. is_nan(fgrid)), dim=1), IK) +fopt = fgrid(kopt) +!!MATLAB: [fopt, kopt] = min(fgrid, [], 'omitnan'); +fprev = fgrid(modulo(kopt - 2_IK, grid_size) + 1) ! Corresponds to KOPT - 1 +fnext = fgrid(modulo(kopt, grid_size) + 1) ! Corresponds to KOPT + 1 + +step = ZERO +if (abs(fprev - fnext) > 0) then + fprev = fprev - fopt + fnext = fnext - fopt + step = HALF * (fprev - fnext) / (fprev + fnext) +end if + +if (is_finite(step) .and. abs(step) > 0) then + unit_angle = (TWO * PI) / real(grid_size, RP) + angle = (real(kopt - 1, RP) + step) * unit_angle + ! 1. AGRID(KOPT) = (KOPT-1) * UNIT_ANGLE. 2. ANGLE may not be in [0, 2*PI]. +else + angle = agrid(kopt) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(is_finite(angle), 'ANGLE is finite', srname) +end if + +end function circle_min + + +function circle_maxabs(fun, args, grid_size) result(angle) +!--------------------------------------------------------------------------------------------------! +! This function seeks an approximate maximizer of the absolute value of a 2*PI-periodic function +! FUN(X, ARGS), where the scalar X is the decision variable, and ARGS is a given vector of parameters. +! It evaluates the function at an evenly distributed "grid" on [0, 2*PI], the number of grid points +! being GRID_SIZE. Then it takes the grid point with the largest value of |FUN|, and improves the +! point by a step that maximizes the absolute value of the quadratic that interpolates FUN on this +! point and its two nearest neighbours. The objective function FUN can represent the parametrization +! of a function defined on the circle, which explains the name of this function. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TWO, HALF, PI, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : linspace +implicit none + +! Inputs +procedure(FUNC_WITH_ARGS) :: fun +real(RP), intent(in) :: args(:) +integer(IK), intent(in) :: grid_size + +! Outputs +real(RP) :: angle + +! Local variables +character(len=*), parameter :: srname = 'CIRCLE_MAXABS' +integer(IK) :: k +integer(IK) :: kopt +real(RP) :: agrid(grid_size + 1) +real(RP) :: fprev +real(RP) :: fnext +real(RP) :: fopt +real(RP) :: fgrid(grid_size) +real(RP) :: step +real(RP) :: unit_angle + +! Preconditions +if (DEBUGGING) then + call assert(grid_size >= 3, 'GRID_SIZE >= 3', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +agrid = linspace(ZERO, TWO * PI, grid_size + 1_IK) ! Size: GRID_SIZE+1; the last entry is not used +fgrid = [(fun(agrid(k), args), k=1, grid_size)] +!!MATLAB: fgrid = arrayfun(@(angle) fun(angle, args), agrid(1:grid_size)); % Same shape as `agrid` + +if (all(is_nan(fgrid))) then + angle = ZERO + return +end if + +kopt = int(maxloc(abs(fgrid), mask=(.not. is_nan(fgrid)), dim=1), IK) +!!MATLAB: [~, kopt] = max(abs(fgrid), [], 'omitnan'); +fopt = fgrid(kopt) +fprev = fgrid(modulo(kopt - 2_IK, grid_size) + 1) ! Corresponds to KOPT - 1 +fnext = fgrid(modulo(kopt, grid_size) + 1) ! Corresponds to KOPT + 1 + +step = ZERO +if (abs(fprev - fnext) > 0) then + fprev = fprev - fopt + fnext = fnext - fopt + step = HALF * (fprev - fnext) / (fprev + fnext) +end if + +if (is_finite(step) .and. abs(step) > 0) then + unit_angle = (TWO * PI) / real(grid_size, RP) + angle = (real(kopt - 1, RP) + step) * unit_angle + ! 1. AGRID(KOPT) = (KOPT-1) * UNIT_ANGLE. 2. ANGLE may not be in [0, 2*PI]. +else + angle = agrid(kopt) +end if + +! Postconditions +if (DEBUGGING) then + call assert(is_finite(angle), 'ANGLE is finite', srname) +end if + +end function circle_maxabs + + +function interval_max(fun, lb, ub, args, grid_size) result(x) +!--------------------------------------------------------------------------------------------------! +! This function seeks an approximate maximizer of a function F(X, ARGS) for X in [LB, UB], where +! ARGS is a vector of parameters. It evaluates the function at an evenly distributed "grid" on +! [LB, UB], the number of grid points being GRID_SIZE. Then it takes the grid point with the largest +! value of FUN, and improves the point by a step that maximizes the quadratic that interpolates +! FUN on this point and its two nearest neighbours unless the point is LB or UB. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, IK, HALF, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan +use, non_intrinsic :: linalg_mod, only : linspace +implicit none + +! Inputs +procedure(FUNC_WITH_ARGS) :: fun +real(RP), intent(in) :: lb +real(RP), intent(in) :: ub +real(RP), intent(in) :: args(:) +integer(IK), intent(in) :: grid_size + +! Outputs +real(RP) :: x + +! Local variables +character(len=*), parameter :: srname = 'INTERVAL_MAX' +integer(IK) :: k +integer(IK) :: kopt +real(RP) :: fgrid(grid_size) +real(RP) :: fopt +real(RP) :: fnext +real(RP) :: fprev +real(RP) :: step +real(RP) :: xgrid(grid_size) + +! Preconditions +if (DEBUGGING) then + call assert(is_finite(lb) .and. is_finite(ub) .and. lb <= ub, 'LB <= UB and they are finite', srname) + call assert(grid_size >= 3, 'GRID_SIZE >= 3', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (ub <= lb) then + x = lb + return +end if + +xgrid = linspace(lb, ub, grid_size) +fgrid = [(fun(xgrid(k), args), k=1, grid_size)] +!!MATLAB: fgrid = arrayfun(@(x) fun(x, args), xgrid(1:grid_size)); % Same shape as `xgrid` + +if (all(is_nan(fgrid))) then + x = lb + return +end if + +kopt = int(maxloc(fgrid, mask=(.not. is_nan(fgrid)), dim=1), IK) +fopt = fgrid(kopt) +!!MATLAB: [fopt, kopt] = min(fgrid, [], 'omitnan'); + +if (kopt == 1) then + x = lb +elseif (kopt == grid_size) then + x = ub +else + fprev = fgrid(kopt - 1) + fnext = fgrid(kopt + 1) + step = ZERO + if (abs(fprev - fnext) > 0) then + step = HALF * ((fnext - fprev) / (fopt + fopt - fprev - fnext)) + end if + if (is_finite(step) .and. abs(step) > 0) then + x = lb + (ub - lb) * (real(kopt - 1, RP) + step) / real(grid_size - 1, RP) + ! N.B.: 1. XGRID(KOPT) = LB + (UB-LB)*(KOPT - 1)/(GRID_SIZE -1) + ! 2. XGRID(KOPT-1) <= X <= XGRID(KOPT+1), as X maximizes the quadratic interpolant. + else + x = xgrid(kopt) + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(lb <= x .and. x <= ub, 'LB <= X <= UB', srname) +end if + +end function interval_max + + +end module univar_mod diff --git a/examples/fortran/prima/native/common/xinbd.f90 b/examples/fortran/prima/native/common/xinbd.f90 new file mode 100644 index 000000000..a85af63b6 --- /dev/null +++ b/examples/fortran/prima/native/common/xinbd.f90 @@ -0,0 +1,79 @@ +module xinbd_mod + +implicit none + +private +public :: xinbd + + +contains + + +function xinbd(xbase, step, xl, xu, sl, su) result(x) +!--------------------------------------------------------------------------------------------------! +! This function sets X to XBASE + STEP, paying careful attention to the following bounds. +! 1. XBASE is a point between XL and XU (guaranteed); +! 2. STEP is a step between SL and SU (may be with rounding errors); +! 3. SL = XL - XBASE, SU = XU - XBASE; +! 4. X should be between XL and XU. +!--------------------------------------------------------------------------------------------------! +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, EPS, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : trueloc +use, non_intrinsic :: infnan_mod, only : is_finite + +implicit none + +! Inputs +real(RP), intent(in) :: xbase(:) +real(RP), intent(in) :: step(:) +real(RP), intent(in) :: xl(:) +real(RP), intent(in) :: xu(:) +real(RP), intent(in) :: sl(:) +real(RP), intent(in) :: su(:) + +! Outputs +real(RP) :: x(size(xbase)) + +! Local variables +character(len=*), parameter :: srname = 'XINBD' +integer(IK) :: n +real(RP) :: s(size(xbase)) + +! Sizes +n = int(size(xbase), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(size(xl) == n .and. size(xu) == n, 'SIZE(XL) == N == SIZE(XU)', srname) + call assert(all(xbase >= xl .and. xbase <= xu), 'XL <= XBASE <= XU', srname) + call assert(size(sl) == n .and. size(su) == n, 'SIZE(SL) == N == SIZE(SU)', srname) + call assert(all(step + 1.0E2_RP * EPS * max(ONE, abs(step)) >= sl .and. & + & step - 1.0E2_RP * EPS * max(ONE, abs(step)) <= su), 'SL <= STEP <= SU', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +s = max(sl, min(su, step)) +x = max(xl, min(xu, xbase + s)) +x(trueloc(s <= sl)) = xl(trueloc(s <= sl)) +x(trueloc(s >= su)) = xu(trueloc(s >= su)) + +!====================! +! Calculation ends ! +!====================! + +if (DEBUGGING) then + call assert(size(x) == n .and. all(x >= xl .and. x <= xu), 'SIZE(X) == N, XL <= X <= XU', srname) + call assert(all(x <= xl .or. step > sl), 'X == XL if STEP <= SL', srname) + call assert(all(x >= xu .or. step < su), 'X == XU if STEP >= SU', srname) +end if + +end function xinbd + + +end module xinbd_mod diff --git a/examples/fortran/prima/native/lincoa/geometry.f90 b/examples/fortran/prima/native/lincoa/geometry.f90 new file mode 100644 index 000000000..b01613afb --- /dev/null +++ b/examples/fortran/prima/native/lincoa/geometry.f90 @@ -0,0 +1,476 @@ +module geometry_lincoa_mod +!--------------------------------------------------------------------------------------------------! +! This module contains subroutines concerning the geometry-improving of the interpolation set XPT. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Sunday, April 21, 2024 PM03:15:36 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: setdrop_tr, geostep + + +contains + + +function setdrop_tr(idz, kopt, ximproved, bmat, d, delta, rho, xpt, zmat) result(knew) +!--------------------------------------------------------------------------------------------------! +! This subroutine sets KNEW to the index of the interpolation point to be deleted AFTER A TRUST +! REGION STEP. KNEW will be set in a way ensuring that the geometry of XPT is "optimal" after +! XPT(:, KNEW) is replaced with XNEW = XOPT + D, where D is the trust-region step. +! N.B.: +! It is tempting to take the function value into consideration when defining KNEW, for example, +! set KNEW so that FVAL(KNEW) = MAX(FVAL) as long as F(XNEW) < MAX(FVAL), unless there is a better +! choice. However, this is not a good idea, because the definition of KNEW should benefit the +! quality of the model that interpolates f at XPT. A set of points with low function values is not +! necessarily a good interpolation set. In contrast, a good interpolation set needs to include +! points with relatively high function values; otherwise, the interpolant will unlikely reflect the +! landscape of the function sufficiently. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, TENTH, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : issymmetric, trueloc +use, non_intrinsic :: powalg_mod, only : calden + +implicit none + +! Inputs +integer(IK), intent(in) :: idz +integer(IK), intent(in) :: kopt +logical, intent(in) :: ximproved +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: delta +real(RP), intent(in) :: rho +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Outputs +integer(IK) :: knew + +! Local variables +character(len=*), parameter :: srname = 'SETDROP_TR' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: den(size(xpt, 2)) +real(RP) :: distsq(size(xpt, 2)) +real(RP) :: score(size(xpt, 2)) +real(RP) :: weight(size(xpt, 2)) + +! Sizes +n = int(size(xpt, 1), kind(npt)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(delta >= rho .and. rho > 0, 'DELTA >= RHO > 0', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Calculate the distance squares between the interpolation points and the "optimal point". When +! identifying the optimal point, it is reasonable to take into account the new trust-region trial +! point XPT(:, KOPT) + D, which will become the optimal point in the next iteration if XIMPROVED +! is TRUE. Powell suggested this in +! - (56) of the UOBYQA paper, lines 276--297 of uobyqb.f, +! - (7.5) and Box 5 of the NEWUOA paper, lines 383--409 of newuob.f, +! - the last paragraph of page 26 of the BOBYQA paper, lines 435--465 of bobyqb.f. +! However, Powell's LINCOA code is different. In his code, the KNEW after a trust-region step is +! picked in lines 72--96 of the update.f for LINCOA, where DISTSQ is calculated as the square of the +! distance to XPT(KOPT, :) (Powell recorded the interpolation points in rows). However, note that +! the trust-region trial point has not been included into XPT yet --- it cannot be included without +! knowing KNEW (see lines 332-344 and 404--431 of lincob.f). Hence Powell's LINCOA code picks KNEW +! based on the distance to the un-updated "optimal point", which is unreasonable. This has been +! corrected in our implementation of LINCOA, yet it does not boost the performance. +if (ximproved) then + distsq = sum((xpt - spread(xpt(:, kopt) + d, dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - (xpt(:, kopt) + d)).^2) % d should be a column!! Implicit expansion +else + distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - xpt(:, kopt)).^2) % Implicit expansion +end if +!distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) ! Powell's code + +weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**3 ! Powell's NEWUOA code +! Other possible definitions of WEIGHT. +! !weight = distsq**2 ! Powell's code. WRONG. +! !weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**2.5 ! Worse than power 3 +! !weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**3.5 ! Worse than power 3 +! !weight = (distsq / delta**2)**2 ! Works the same as DISTSQ**2 (as it should be). +! !weight = (distsq / delta**2)**3 ! Not bad +! !weight = max(1.0_RP, 10.0_RP * distsq / rho**2)**3 +! !weight = max(1.0_RP, 1.0E2 * distsq / rho**2)**3 +! !weight = max(1.0_RP, 10.0_RP * distsq / delta**2)**3 +! !weight = max(1.0_RP, 1.0E2_RP * distsq / delta**2)**3 +!--------------------------------------------------------------------------------------------------! +! N.B.: If DISTSQ is the square of distances to the updated XOPT, then it is WRONG to set WEIGHT to +! DISTSQ**2 or any power of DISTSQ. Why? +! +! Consider a scenario where XIMPROVED is TRUE and the new interpolation point XNEW is quite close to +! one of the existing points in the old XPT, e.g., XPT(:, J). In this case, the only appropriate +! value of KNEW is J; otherwise, the new interpolation problem will be close to degenerate and its +! KKT system will be close to singular due to the two close points in the updated interpolation set. +! +! What KNEW will be generated if KNEW = MAXLOC(DISTSQ**p * ABS(DEN))? If ||XNEW - XPT(:, J)|| = E, +! we have the following. +! 1. DISTSQ(J) = O(E**2) and DEN(J) = O(1); +! 2. for any K /= J, DIST(K) = O(1) and DEN(K) = O(E). +! Therefore, for any p > 1/2, KNEW /= J when E is small. As analyzed above, this is inappropriate. +! In addition, small values of p (e.g., p <= 1/2) always performs poorly for all Powell's methods +! in our numerical experiments. +! +! For the order of DEN, note the DEN(K) is the denominator in the Sherman-Morrison-Woodbury update +! of the KKT matrix, and DEN(K) = det(new KKT matrix) / det(old KKT matrix), where "KKT matrix" +! refers to the coefficient matrix of the KKT system for the interpolation problem. See equations +! (3.10)--(3.12) of the NEWUOA paper for this matrix. +! +! Similar arguments can be made if the interpolation is fully determined. Indeed, the usage of +! DISTSQ as the weight led to a problem in COBYLA during a test on 20230501, which is the very +! motivation for the current comment. +! +! Note that Powell's LINCOA code sets DISTSQ to the square of the distance to the old XOPT, which +! avoids this problem. However, such a DISTSQ itself seems not ideal, as mentioned above. +!--------------------------------------------------------------------------------------------------! + +den = calden(kopt, bmat, d, xpt, zmat, idz) +score = weight * abs(den) + +! If the new F is not better than FVAL(KOPT), we set SCORE(KOPT) = -1 to avoid KNEW = KOPT. +if (.not. ximproved) then + score(kopt) = -ONE +end if + +! SCORE(K) is NaN implies ABS(DEN(K)) is NaN, but we want ABS(DEN) to be big. So we exclude such K. +score(trueloc(is_nan(score))) = -ONE + +knew = 0 +! The following IF works a bit better than `IF (ANY(SCORE > 1) .OR. ANY(SCORE > 0) .AND. XIMPROVED)` +! from Powell's UOBYQA and NEWUOA code. +if (any(score > 0)) then ! Powell's BOBYQA and LINCOA code + knew = int(maxloc(score, dim=1), kind(knew)) + !!MATLAB: [~, knew] = max(score); +end if + +! Powell's code does not include the following instructions. With Powell's code, if DEN consists of +! only NaN, then KNEW can be 0 even when XIMPROVED is TRUE. Here, we set KNEW to the following value, +! to make sure that the new trial point is included in the interpolation set. However, the updating +! subroutine will likely need to skip the update of the Lagrange polynomials (i.e., H), or they +! would be destroyed by the NaNs. +if ((ximproved .and. knew == 0) .or. knew < 0) then ! KNEW < 0 is impossible in theory. + knew = int(maxloc(distsq, dim=1), kind(knew)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(knew /= kopt .or. ximproved, 'KNEW /= KOPT unless XIMPROVED = TRUE', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless XIMPROVED = FALSE', srname) + ! KNEW >= 1 when XIMPROVED = TRUE unless NaN occurs in DISTSQ, which should not happen if the + ! starting point does not contain NaN and the trust-region/geometry steps never contain NaN. +end if +end function setdrop_tr + + +subroutine geostep(iact, idz, knew, kopt, nact, amat, bmat, delbar, qfac, rescon, xpt, zmat, feasible, s) +!--------------------------------------------------------------------------------------------------! +! This subroutine finds a step S hat intends to improve the geometry of the interpolation set when +! XPT(:, KNEW) is changed to XOPT + S, where XOPT = XPT(:, KOPT). +! +! S is chosen to provide a relatively large value of the modulus of the denominator SIGMA in the +! updating formula (4.11) of the NEWUOA paper (in theory, SIGMA is positive, yet this may not hold +! numerically due to rounding errors; in the code, SIGMA is represented by DEN and its modulus by +! DENABS). This is done by solving +! +! |LFUNC(XOPT + S)|, subject to ||S|| <= DELBAR, +! +! because SIGMA >= |LFUNC(XOPT + S)|^2 according to (4.12) of the NEWUOA paper. We do not solve this +! problem exactly, but calculate three approximate solutions as follows and then choose S from them. +! 1. The step that maximizes |LFUNC| within the trust region on the lines through XOPT and other +! interpolation points. +! 2. The gradient step that maximizes |LFUNC| within the trust region. +! 3. A projected gradient step that maximizes |LFUNC| within the trust region, the projection being +! made onto the orthogonal complement of the space spanned by the active gradients. +! +! We select S from these three steps by the following criteria. +! 1. First, set S to either the first or second step, whichever renders a larger value of |SIGMA|. +! 2. Second, override S by the third step if the latter provides a |SIGMA| that is not small +! compared with the above one, while leading to a good feasibility. +! +! N.B.: +! 1. The linear constraints are NOT considered in the calculation of the first two steps. +! 2. For the selection of S, Powell adopted a different set of criteria as follows. +! 2.1. First, set S to either the first or second step, whichever renders a larger value of |LFUNC|. +! 2.2. Second, override S by the third step if the latter provides a |LFUNC| that is not small +! compared with the above one, while being either feasible or with a constraint violation that is at +! least 0.2*DELBAR. +! 2.3. If S is not feasible and its constraint violation is less than 0.2*DELBAR, then it is +! perturbed so that the constraint violation becomes 0.2*DELBAR or more. +! 3. Powell required the positive constraint violation to be at least 0.2*DELBAR in order to keep +! the interpolation points apart. In our criteria specified above, we have removed this requirement +! as we believe that it is implied by the maximization of |LFUNC|. Our criteria works well in tests. +! 4. In terms of flops, our criteria are more expensive than Powell's due to the evaluation of SIGMA. +! In derivative-free optimization, we are willing to save function evaluations at the cost of flops. +! 5. The geometry step of BOBYQA is calculated in a fashion similar to this subroutine: first obtain +! a step by maximizing |LFUNC| along the lines through XOPT and other interpolation points, then +! find the Cauchy step, which maximizes |LFUNC| in the 1D space spanned by the gradient of LFUNC, +! and finally select the geometry step from the aforesaid steps according to the value of |LFUNC| or +! SIGMA. Yet there still exist three major differences between geometry steps of BOBYQA and LINCOA. +! 5.1. The geometry step of BOBYQA is calculated subject to the bound constraints, and the computed +! step is always feasible; the geometry step of LINCOA may violate the linear constraints. +! 5.2. BOBYQA uses an estimated value of SIGMA (see (3.11) of the BOBYQA paper) to select the step +! along the lines through XOPT and other interpolation points; LINCOA uses |LFUNC|. According to +! a test on 20220529, using the estimated SIGMA does not improve the performance of LINCOA. +! 5.3. LINCOA tries a projected gradient step and prefers this step when its quality is reasonable. +! BOBYQA does not compute such a step. +! Additionally, we observe in BOBYQA that it is beneficial for bound constrained problems (but NOT +! unconstrained ones) to take the Cauchy step only in the late stage of the algorithm, e.g., when +! DELBAR <= 1.0E-2. Similar phenomenon is not observed in LINCOA, where it worsens the performance +! of the algorithm to skip the gradient step or the projected gradient step even in the early stage. +! +! AMAT, XPT, NACT, IACT, RESCON, QFAC, KOPT are the same as the terms with these names in subroutine +! LINCOB. KNEW is the index of the interpolation point that is going to be moved. DELBAR is the +! restriction on the length of S, which is never greater than the current trust region radius DELTA. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, TEN, TENTH, MAXPOW10, EPS, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : matprod, inprod, isorth, maximum, trueloc, norm +use, non_intrinsic :: powalg_mod, only : hess_mul, omega_col, calden + +implicit none + +! Inputs +integer(IK), intent(in) :: iact(:) ! IACT(M) +integer(IK), intent(in) :: idz +integer(IK), intent(in) :: knew +integer(IK), intent(in) :: kopt +integer(IK), intent(in) :: nact +real(RP), intent(in) :: amat(:, :) ! AMAT(N, M) +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT+N) +real(RP), intent(in) :: delbar +real(RP), intent(in) :: qfac(:, :) ! QFAC(N, N) +real(RP), intent(in) :: rescon(:) ! RESCON(M) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT-N-1) + +! Outputs +logical, intent(out) :: feasible +real(RP), intent(out) :: s(:) ! S(N) + +! Local variables +character(len=*), parameter :: srname = 'GEOSTEP' +integer(IK) :: k +integer(IK) :: m +integer(IK) :: n +integer(IK) :: npt +integer(IK) :: rstat(size(amat, 2)) +logical :: take_pgstp +real(RP) :: cstrv +real(RP) :: cvtol +real(RP) :: dderiv(size(xpt, 2)) +real(RP) :: den(size(xpt, 2)) +real(RP) :: denabs +real(RP) :: distsq(size(xpt, 2)) +real(RP) :: glag(size(xpt, 1)) +real(RP) :: gstp(size(xpt, 1)) +real(RP) :: gnorm +real(RP) :: pglag(size(xpt, 1)) +real(RP) :: pgstp(size(xpt, 1)) +real(RP) :: pqlag(size(xpt, 2)) +real(RP) :: scaling +real(RP) :: stplen(size(xpt, 2)) +real(RP) :: tol +real(RP) :: vlagabs(size(xpt, 2)) +real(RP) :: xopt(size(xpt, 1)) + +! Sizes. +m = int(size(amat, 2), kind(m)) +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(npt >= n + 2, 'NPT >= N+2', srname) + call assert(nact >= 0 .and. nact <= min(m, n), '0 <= NACT <= MIN(M, N)', srname) + call assert(size(iact) == m, 'SIZE(IACT) == M', srname) + call assert(all(iact(1:nact) >= 1 .and. iact(1:nact) <= m), '1 <= IACT <= M', srname) + call assert(idz >= 1 .and. idz <= npt - n, '1 <= IDZ <= NPT-N', srname) + call assert(knew >= 1 .and. knew <= npt, '1 <= KNEW <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew /= kopt, 'KNEW /= KOPT', srname) + call assert(size(amat, 1) == n .and. size(amat, 2) == m, 'SIZE(AMAT) == [N, M]', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT) == [N, NPT+N]', srname) + call assert(delbar > 0, 'DELBAR> 0', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(8, MAXPOW10) * EPS * real(n, RP))) + call assert(isorth(qfac, tol), 'QFAC is orthogonal', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + call assert(size(rescon) == m, 'SIZE(RESCON) == M', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, 'SIZE(ZMAT) == [NPT, NPT- N-1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Read XOPT. +xopt = xpt(:, kopt) + +! PQLAG contains the leading NPT elements of the KNEW-th column of H, and it provides the second +! derivative parameters of LFUNC. Set GLAG to the gradient of LFUNC at the trust region centre. +pqlag = omega_col(idz, zmat, knew) +glag = bmat(:, knew) + hess_mul(xopt, xpt, pqlag) + +! Maximize |LFUNC| within the trust region on the lines through XOPT and other interpolation points, +! without considering the linear constraints. In the following, VLAGABS(K) is set to the maximum of +! |PHI_K(t)| subject to the trust-region constraint with PHI_K(t) = LFUNC((1-t)*XOPT + t*XPT(:, K)). +dderiv = matprod(glag, xpt) - inprod(glag, xopt) ! The derivatives PHI_K'(0). +distsq = sum((xpt - spread(xopt, dim=2, ncopies=npt))**2, dim=1) +! Set DISTSQ(KOPT) to a positive artificial value. Otherwise, the calculation of STPLEN will raise a +! floating point exception. This artificial value will NOT be used. +distsq(kopt) = ONE +! For each K /= KNEW, |PHI_K(t)| is maximized by STPLEN(K), the maximum being VLAGABS(K). Note that +! PHI_K(t) is a quadratic function with PHI_K'(0) = DDERIV(K) and PHI_K(0) = 0 = PHI_K(1). +stplen = -delbar / sqrt(distsq) +vlagabs = abs(stplen * (ONE - stplen) * dderiv) +! The maximization of |PHI_K(t)| is as follows. Note that PHI_K(t) is a quadratic function with +! PHI_K'(0) = DDERIV(K), PHI_K(0) = 0, and PHI_K(1) = 1. +if (dderiv(knew) * (dderiv(knew) - ONE) < 0) then + stplen(knew) = -stplen(knew) +end if +vlagabs(knew) = abs(stplen(knew) * dderiv(knew)) + stplen(knew)**2 * abs(dderiv(knew) - ONE) +! It does not make sense to consider "the straight line through XOPT and XPT(:, KOPT)". Thus we set +! VLAGABS(KOPT) to -1 so that KOPT is skipped when we maximize VLAGABS. +vlagabs(kopt) = -ONE +! Find K so that VLAGABS(K) is maximized. We define K in a way slightly different from Powell's +! code, which sets K to MAXLOC(VLAGABS) by comparing the entries of VLAGABS sequentially. +! 1. If VLAGABS contains only NaN, which can happen, Powell's code leaves K uninitialized. +! 2. If VLAGABS(KNEW) = MAXVAL(VLAGABS) = VLAGABS(K) and K < KNEW, Powell's code does not set K=KNEW. +k = knew +if (any(vlagabs > vlagabs(knew))) then + k = int(maxloc(vlagabs, mask=(.not. is_nan(vlagabs)), dim=1), kind(k)) + !!MATLAB: [~, k] = max(vlagabs, [], 'omitnan'); +end if +! Set S to the step corresponding to VLAGABS(K), and calculate DENABS for it. +s = stplen(k) * (xpt(:, k) - xopt) +den = calden(kopt, bmat, s, xpt, zmat, idz) ! Indeed, only DEN(KNEW) is needed. +denabs = abs(den(knew)) + +! Replace S with a steepest ascent step from XOPT if the latter provides a larger value of DENABS. +gnorm = norm(glag) +if (gnorm > EPS .and. is_finite(gnorm)) then + gstp = (delbar / gnorm) * glag + if (inprod(gstp, hess_mul(gstp, xpt, pqlag)) < 0) then ! is negative + gstp = -gstp + end if + den = calden(kopt, bmat, gstp, xpt, zmat, idz) ! Indeed, only DEN(KNEW) is needed. + if (abs(den(knew)) > denabs .or. is_nan(denabs)) then + denabs = abs(den(knew)) + s = gstp + end if +end if + +! RSTAT identifies the constraints that need evaluation. RSTAT(J) is -1, 0, or 1 respectively means +! constraint J is irrelevant, active, or inactive and relevant. Do NOT change the order of the lines +! that set RSTAT, as the later lines override the earlier. +rstat = 1 ! Inactive and relevant +rstat(trueloc(abs(rescon) >= delbar)) = -1 ! Irrelevant +rstat(iact(1:nact)) = 0 ! Active + +! Set FEASIBLE for the calculated S. +cstrv = maximum([ZERO, matprod(s, amat(:, trueloc(rstat >= 0))) - rescon(trueloc(rstat >= 0))]) +feasible = (cstrv <= 0) + +! If NACT <= 0 or NACT >= N, the calculation has finished. Otherwise, define PGSTP by maximizing +! |LFUNC| within the trust region from XOPT along the projection of GLAG onto the column space of +! QFAC(:, NACT+1:N), i.e., the orthogonal complement of the space spanned by the active gradients. +! In precise arithmetic, moving along PGSTP does not change the values of the active constraints. +! This projected gradient step is preferred and will override S if it renders a denominator not too +! small and leads to good feasibility. *** This is critical for the performance of LINCOA. *** +! In the following, NORMG > EPS prevents floating point exception, and it implies NACT < N. +pglag = matprod(qfac(:, nact + 1:n), matprod(glag, qfac(:, nact + 1:n))) +!!MATLAB: pglag = qfac(:, nact+1:n) * (glag' * qfac(:, nact+1:n))'; +gnorm = norm(pglag) +if (nact > 0 .and. gnorm > EPS .and. is_finite(gnorm)) then + pgstp = (delbar / gnorm) * pglag + if (inprod(pgstp, hess_mul(pgstp, xpt, pqlag)) < 0) then ! is negative. + pgstp = -pgstp + end if + + ! Decide whether to replace S with PGSTP and set FEASIBLE accordingly. CSTRV is the constraint + ! violation of XOPT+PGSTP. Note that we only need to check the constraints that are inactive and + ! relevant, as the value of the active constraints is not changed by moving along PGSTP. + cstrv = maximum([ZERO, matprod(pgstp, amat(:, trueloc(rstat == 1))) - rescon(trueloc(rstat == 1))]) + ! The purpose of CVTOL below is to provide a check on feasibility that includes a tolerance for + ! contributions from computer rounding errors. + ! Powell's code is as follows. Note that MATPROD(PGSTP, AMAT(:, IACT(1:NACT))) is 0 in theory. + ! !cvtol = min(0.01_RP * norm(pgstp), TEN * norm(matprod(pgstp, amat(:, iact(1:nact))), 'inf')) + ! The following code works essentially the same as Powell's code. + cvtol = max(EPS * norm(pgstp), TEN * norm(matprod(pgstp, amat(:, iact(1:nact))), 'inf')) + take_pgstp = .false. + if (cstrv <= cvtol) then + den = calden(kopt, bmat, pgstp, xpt, zmat, idz) ! Indeed, only DEN(KNEW) is needed. + take_pgstp = (abs(den(knew)) > TENTH * denabs) + end if + if (take_pgstp .or. is_nan(denabs)) then + s = pgstp + feasible = (cstrv <= cvtol) + end if +end if + +! In case S is zero or contains Inf/NaN, replace it with a displacement from XPT(:, KNEW) to +! XOPT. Powell's code does not have this. +if (sum(abs(s)) <= 0 .or. .not. is_finite(sum(abs(s)))) then + s = xpt(:, knew) - xopt + scaling = delbar / norm(s) + s = max(0.6_RP * scaling, min(HALF, scaling)) * s ! 0.6: ensure |D| > DELBAR/2 + cstrv = maximum([ZERO, matprod(s, amat(:, trueloc(rstat >= 0))) - rescon(trueloc(rstat >= 0))]) + feasible = (cstrv <= 0) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(s) == n, 'SIZE(S) == N', srname) + call assert(all(is_finite(s)), 'S is finite', srname) + ! In theory, ||S|| = DELBAR. Considering rounding errors, we check that DELBAR/2 < ||S|| < 2*DELBAR. + ! It is crucial to ensure that the geometry step is nonzero. + call assert(norm(s) > HALF * delbar .and. norm(s) < TWO * delbar, 'DELBAR/2 < ||S|| < 2*DELBAR', srname) +end if + +end subroutine geostep + + +end module geometry_lincoa_mod diff --git a/examples/fortran/prima/native/lincoa/getact.f90 b/examples/fortran/prima/native/lincoa/getact.f90 new file mode 100644 index 000000000..3876f067d --- /dev/null +++ b/examples/fortran/prima/native/lincoa/getact.f90 @@ -0,0 +1,589 @@ +module getact_mod +!--------------------------------------------------------------------------------------------------! +! This module provides the GETACT subroutine of LINCOA. It is used only in the trust-region +! subproblem solver. We do not put it in trustregion.f90 as it is too long. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the paper +! +! M. J. D. Powell, On fast trust region methods for quadratic models with linear constraints, +! Math. Program. Comput., 7:237--267, 2015 +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Saturday, March 09, 2024 PM12:12:21 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: getact + + +contains + + +subroutine getact(amat, delta, g, iact, nact, qfac, resact, resnew, rfac, psd) +!--------------------------------------------------------------------------------------------------! +!-------------------------------------------------------------! +! THE FOLLOWING DESCRIPTION NEEDS VERIFICATION! ! +! Note that the set JJ gets updated within this subroutine, ! +! which seems inconsistent with the description below. ! +! See the lines below "Pick the next integer L or terminate". ! +!-------------------------------------------------------------! +! +! This subroutine solves a linearly constrained projected problem (LCPP) +! +! min ||D + G|| subject to AMAT(:, j)^T * D <= 0 for j in JJ. +! +! The solution is PSD, which is a projected steepest descent direction PSD for a linearly +! constrained trust-region subproblem (LCTRS) +! +! min Q(X_k + D) subject to ||D|| <= Delta and AMAT^T*(X_k + D) <= B, +! +! where X_k is in R^N, B is in R^M, and AMAT is in R^{NxM}. +! +! In (LCPP), JJ is the index set defined in (3.3) of Powell (2015) as +! +! JJ = {j : B_j - A_j^T*Y <= 0.2*Delta*||A_j||, 1 <= j <= M} with A_j = AMAT(:, j), +! +! i.e., the index set of the nearly active constraints of (LCTRS) (Powell wrote that j is in JJ if +! and only if the distance from Y to the boundary of the j-th constraint is at most 0.2*Delta). +! Here, Y is the point where G is taken, namely G = nabla Q(Y). Y is not necessarily X_k, but an +! iterate of the algorithm (e.g., truncated conjugate gradient) that solves (LCTRS). In LINCOA, +! ||A_j|| is 1 as the gradients of the linear constraints are normalized before LINCOA starts. +! +! The subroutine solves (LCPP) by the active set method of Goldfarb-Idnani (1983). It does not only +! calculate PSD, but also identify the active set of (LCPP) at the solution PSD, namely +! +! II = {j in JJ : AMAT(:, j)^T*PSD = 0} (see (3.5) of Powell (2015)), +! +! and maintains a QR factorization of A corresponding to the active set. More specifically, +! IACT(1:NACT) is a set of indices such that the columns of AMAT(:, IACT(1:NACT)) constitute a basis +! of the "active constraint" gradients (i.e., those corresponding to the set II mentioned above, but +! not JJ!), and QFAC*RFAC(:, 1:NACT) is the QR factorization of! AMAT(:, IACT(1:NACT)) such that +! +! SIZE(QFAC) = [N, N], SIZE(RFAC, 1) = N, diag(RFAC(:, 1:NACT)) > 0. +! +! NACT, IACT, QFAC and RFAC are maintained up to date across invocations of GETACT for warm starts. +! +! DELTA, RESNEW, RESACT, and G are the same as the terms with these names in SUBROUTINE TRSTEP. +! The elements of RESNEW and RESACT are also kept up to date. See Section 3 of Powell (2015). +! Note that the updates only permute RESACT but do not change the values inside. +! +! VLAM is the vector of Lagrange multipliers of the calculation. +! +! See Section 3 of Powell (2015) for more information. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, TEN, MAXPOW10, EPS, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan +use, non_intrinsic :: linalg_mod, only : matprod, inprod, eye, istriu, isorth, norm, lsqr, solve, trueloc + +implicit none + +! Inputs +real(RP), intent(in) :: amat(:, :) ! AMAT(N, M) +real(RP), intent(in) :: delta +real(RP), intent(in) :: g(:) ! G(N) + +! In-outputs +integer(IK), intent(inout) :: iact(:) ! IACT(M) +integer(IK), intent(inout) :: nact +real(RP), intent(inout) :: qfac(:, :) ! QFAC(N, N) +real(RP), intent(inout) :: resact(:) ! RESACT(M) +real(RP), intent(inout) :: resnew(:) ! RESNEW(M) +real(RP), intent(inout) :: rfac(:, :) ! RFAC(N, N) + +! Outputs +real(RP), intent(out) :: psd(:) ! PSD(N) + +! Local variables +character(len=*), parameter :: srname = 'GETACT' +integer(IK) :: icon +integer(IK) :: iter +integer(IK) :: l +integer(IK) :: m +integer(IK) :: maxiter +integer(IK) :: n +logical :: mask(size(amat, 2)) +real(RP) :: apsd(size(amat, 2)) +real(RP) :: dd +real(RP) :: ddsav +real(RP) :: dnorm +real(RP) :: gg +real(RP) :: frac(size(g)) +real(RP) :: psdsav(size(psd)) +real(RP) :: tdel +real(RP) :: tol +real(RP) :: v(size(g)) +real(RP) :: violmx +real(RP) :: vlam(size(g)) +real(RP) :: vmu(size(g)) +real(RP) :: vmult + +! Sizes. +m = int(size(amat, 2), kind(m)) +n = int(size(g), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(size(amat, 1) == n .and. size(amat, 2) == m, 'SIZE(AMAT) == [N, M]', srname) + call assert(all(is_finite(g)), 'G is finite', srname) + call assert(nact >= 0 .and. nact <= min(m, n), '0 <= NACT <= MIN(M, N)', srname) + call assert(size(iact) == m, 'SIZE(IACT) == M', srname) + call assert(all(iact(1:nact) >= 1 .and. iact(1:nact) <= m), '1 <= IACT <= M', srname) + call assert(size(resact) == m, 'SIZE(RESACT) == M', srname) + call assert(size(resnew) == m, 'SIZE(RESNEW) == M', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(8, MAXPOW10) * EPS * real(n, RP))) + call assert(isorth(qfac, tol), 'QFAC is orthogonal', srname) + call assert(size(rfac, 1) == n .and. size(rfac, 2) == n, 'SIZE(RFAC) == [N, N]', srname) + call assert(istriu(rfac), 'RFAC is upper triangular', srname) + call assert(size(psd) == n, 'SIZE(PSD) == N', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Quick return when M = 0. +if (m <= 0) then + nact = 0 + qfac = eye(n) + psd = -g + return +end if + +! Set some constants. +gg = inprod(g, g) +tdel = 0.2_RP * delta ! Changing TDEL to 0.1_RP*DELTA does not improve the performance of LINCOA. + +! Set the initial QFAC to the identity matrix in the case NACT = 0. +if (nact == 0) then + qfac = eye(n) +end if + +! Remove any constraints from the initial active set whose residuals exceed TDEL. +! Compilers may complain if VLAM is not set. The value does not matter, as it will be overwritten. +vlam = ZERO +do icon = nact, 1, -1 + if (resact(icon) > tdel) then + ! Delete constraint IACT(ICON) from the active set, and set NACT = NACT - 1. + call delact(icon, iact, nact, qfac, resact, resnew, rfac, vlam) + end if +end do + +! Remove any constraints from the initial active set whose Lagrange multipliers are nonnegative, +! and set the surviving multipliers. +! The following loop will run for at most NACT times, since each call of DELACT reduces NACT by 1. +do while (nact > 0) + vlam(1:nact) = lsqr(g, qfac(:, 1:nact), rfac(1:nact, 1:nact)) + if (.not. any(vlam(1:nact) >= 0)) then + exit + end if + icon = maxval(trueloc(vlam(1:nact) >= 0)) + !!MATLAB: icon = max(find(vlam(1:nact) >= 0)); % OR: icon = find(vlam(1:nact) >= 0, 1, 'last') + call delact(icon, iact, nact, qfac, resact, resnew, rfac, vlam) +end do +! Zaikun 20220330: What if NACT = 0 at this point? + +! Set the new search direction D. Terminate if the 2-norm of D is ZERO or does not decrease, or if +! NACT=N holds. The situation NACT=N occurs for sufficiently large DELTA if the origin is in the +! convex hull of the constraint gradients. +! Start with initialization of PSDSAV and DDSAV. +psdsav = ZERO ! Must be set, in case the loop exits due to abnormality at iteration 1. +ddsav = TWO * gg ! By Powell. This value is used at iteration 1 to test whether DD >= DDSAV. Why? + +! What is the theoretical maximal number of iterations in the following procedure? Powell's code for +! this part is essentially a `DO WHILE (NACT < N) ... END DO` loop. We enforce the following maximal +! number of iterations, which is never reached in our tests (indeed, even 2*N cannot be reached). +! N.B.: 1. The formulation of MAXITER below contains a precaution against overflow. In +! MATLAB/Python/Julia/R, we can write maxiter = min(10000, 2*(m + n)) +! 2. The iteration counter ITER never appears in the code of the iterations, as its purpose is +! merely to impose an upper bound on the number of iterations. +maxiter = int(min(10**min(4, range(0_IK)), 2 * int(m + n)), IK) +do iter = 1, maxiter + ! When NACT == N, exit with PSD = 0. Indeed, with a correctly implemented matrix product, the + ! lines below this IF should render DD = 0 and trigger an exit. We make it explicit for clarity. + if (nact >= n) then ! Indeed, NACT > N should never happen. + psd = ZERO + exit + end if + + ! Set PSD to the projection of -G to range(QFAC(:,NACT+1:N)) + psd = -matprod(qfac(:, nact + 1:n), matprod(g, qfac(:, nact + 1:n))) + !!MATLAB: psd = -qfac(:, nact + 1:n) * (g' * qfac(:, nact + 1:n))'; + !----------------------------------------------------------------------------------------------! + ! Zaikun: The schemes below work evidently worse than the one above in a test on 20220417. Why? + !-------------------------------------------------------------------------! + ! VERSION 1: + ! !psd = matprod(qfac(:, 1:nact), matprod(g, qfac(:, 1:nact))) - g + !-------------------------------------------------------------------------! + ! VERSION 2: + ! !if (2 * nact < n) then + ! ! psd = matprod(qfac(:, 1:nact), matprod(g, qfac(:, 1:nact))) - g + ! !else + ! ! psd = -matprod(qfac(:, nact + 1:n), matprod(g, qfac(:, nact + 1:n))) + ! !end if + !-------------------------------------------------------------------------! + !----------------------------------------------------------------------------------------------! + + dd = inprod(psd, psd) + dnorm = sqrt(dd) + + if (dnorm <= EPS .or. is_nan(dnorm)) then + exit + end if + + if (dd >= ddsav) then + psd = ZERO ! Zaikun 20220329: Powell wrote this. Why? + !psd = psdsav ! This does not seem to improve the performance. + exit + end if + + !---------------------------------------------------------------------------------------! + ! Powell's code does not handle the following pathological cases. + if (inprod(psd, g) > 0 .or. .not. is_finite(sum(abs(psd)))) then + psd = psdsav + exit + end if + ! In our tests, tolerating the following cases seems to render better numerical results. + ! !if (dd > gg) then + ! ! psd = (sqrt(gg) / dnorm) * psd + ! ! exit + ! !end if + ! !if (inprod(psd, g) < -gg) then + ! ! exit + ! !end if + !---------------------------------------------------------------------------------------! + + psdsav = psd + ddsav = dd + + ! Pick the next integer L or terminate; a positive L is the index of the most violated constraint. + apsd = matprod(psd, amat) + mask = (resnew > 0 .and. resnew <= tdel .and. apsd > (dnorm / delta) * resnew) + !----------------------------------------------------------------------------------------------! + ! N.B.: the definition of L and VIOLMX can be simplified as follows, but we prefer explicitness. + !L = INT(MAXLOC(APSD, MASK=MASK, DIM=1), IK) ! MAXLOC(...) = 0 if MASK is all FALSE. + !VIOLMX = MAXVAL(APSD, MASK=MASK) ! MAXVAL(...) = -HUGE(APSD) if MASK is all FALSE. + if (any(mask)) then + l = int(maxloc(apsd, mask=mask, dim=1), kind(l)) + violmx = apsd(l) + else + l = 0 + violmx = -REALMAX + end if + !!MATLAB: apsd(mask) = -Inf; [violmx, l] = max(apsd); + ! N.B.: the value of L will differ from the Fortran version if MASK is all FALSE, but this is OK + ! because VIOLMX will be -Inf, which will trigger the `exit` below. This is tricky. Be cautious! + !----------------------------------------------------------------------------------------------! + + ! Terminate if VIOLMX <= 0 (when MASK contains only FALSE) or a positive value of VIOLMX may be + ! due to computer rounding errors. + ! N.B.: 1. Theoretically (but not numerically), APSD(IACT(1:NACT)) = 0 or empty. + ! 2. CAUTION: the Inf-norm of APSD(IACT(1:NACT)) is NOT always MAXVAL(ABS(APSD(IACT(1:NACT)))), + ! as the latter returns -HUGE(APSD) instead of 0 when NACT = 0! In MATLAB, max([]) = []; in + ! Python, R, and Julia, the maximum of an empty array raises errors/warnings (as of 20220318). + ! Powell's condition for the IF is as follows. Very often, the threshold is almost zero. + ! !if (all(.not. mask) .or. violmx <= min(0.01_RP * dnorm, TEN * norm(apsd(iact(1:nact)), 'inf'))) then + ! The following condition works essentially the same as Powell's. However, it ensures that + ! VIOLMX > EPS * DNORM when the EXIT is not triggered, which implies that AMAT(:, L) is not in + ! the range of QFAC(:, 1:NACT). + if (all(.not. mask) .or. violmx <= max(EPS * dnorm, TEN * norm(apsd(iact(1:nact)), 'inf'))) then + exit + end if + + ! Add constraint L to the active set. ADDACT sets NACT = NACT + 1 and VLAM(NACT) = 0. + call addact(l, amat(:, l), iact, nact, qfac, resact, resnew, rfac, vlam) + + ! Set the components of the vector VMU if VIOLMX is positive. + ! N.B.: 1. In theory, NACT > 0 is not needed in the condition below, because VIOLMX must be 0 + ! when NACT is 0. We keep NACT > 0 for security: when NACT <= 0, RFAC(NACT, NACT) is invalid. + ! 2. The loop will run for at most NACT <= N times: if VIOLMX > 0, then ICON > 0, and hence + ! VLAM(ICON) = 0, which implies that DELACT will be called to reduce NACT by 1. + do while (violmx > 0 .and. nact > 0) + v(1:nact - 1) = ZERO + v(nact) = ONE / rfac(nact, nact) ! This is why we must ensure NACT > 0. + ! Solve the linear system RFAC(1:NACT, 1:NACT) * VMU(1:NACT) = V(1:NACT) . + vmu(1:nact) = solve(rfac(1:nact, 1:nact), v(1:nact)) ! VMU(NACT) = V(NACT)/RFAC(NACT,NACT)>0 + !!MATLAB: vmu(1:nact) = rfac(1:nact, 1:nact) \ v(1:nact); + + ! Calculate the multiple of VMU to subtract from VLAM, and update VLAM. + ! N.B.: 1. VLAM(1:NACT-1) < 0 and VLAM(NACT) <= 0 by the updates of VLAM. 2. VMU(NACT) > 0. + ! 3. Only the places where VMU(1:NACT) < 0 is relevant below, if any. + frac = REALMAX + where (vmu(1:nact) < 0 .and. vlam(1:nact) < 0) frac(1:nact) = vlam(1:nact) / vmu(1:nact) + !!MATLAB: frac = vlam / vmu; frac(vmu >= 0 | vlam >= 0) = Inf; + vmult = minval([violmx, frac(1:nact)]) + icon = maxval([0_IK, trueloc(frac(1:nact) <= vmult)]) + !!MATLAB: icon = max([0; find(frac(1:nact) <= vmult)]); % find(frac(1:nact)<=vmult) can be empty + + ! N.B.: 0. The definition of ICON given above is mathematically equivalent to the following. + ! !ICON = MAXVAL(TRUELOC([VIOLMX, FRACMULT(1:NACT)] <= VMULT)) - 1_IK, OR + ! !ICON = INT(MINLOC([VIOLMX, FRACMULT(1:NACT)], DIM=1, BACK=.TRUE.), IK) - 1_IK + ! However, such implementations are problematic in the unlikely case of VMULT = NaN: ICON + ! will be -Inf in the first and unspecified in the second. The MATLAB counterpart of the + ! first implementation will render ICON = [] as `find` (the MATLAB version of TRUELOC) + ! returns []. + ! 1. The BACK argument in MINLOC is available in F2008. Not supported by Absoft as of 2022. + ! 2. A motivation for backward MINLOC is to save computation in DELACT below (what else?). + + violmx = max(violmx - vmult, ZERO) + vlam(1:nact) = vlam(1:nact) - vmult * vmu(1:nact) + if (icon > 0 .and. icon <= nact) then ! Powell: IF (ICON>0). We check ICON<=NACT for safety. + vlam(icon) = ZERO + end if + + ! Reduce the active set if necessary, so that all components of the new VLAM are negative, + ! with resetting of the residuals of the constraints that become inactive. + do icon = nact, 1, -1 + if (vlam(icon) >= 0) then ! Powell's version: IF (.NOT. VLAM(ICON) < 0) THEN + ! Delete the constraint with index IACT(ICON) from the active set; set NACT = NACT-1. + call delact(icon, iact, nact, qfac, resact, resnew, rfac, vlam) + end if + end do + end do ! End of DO WHILE (VIOLMX > 0 .AND. NACT > 0) + + !----------------------------------------------------------------------------------------------! + ! NACT can become 0 at this point iff VLAM(1:NACT) >= 0 before calling DELACT, which is true + ! if NACT happens to be 1 when the WHILE loop starts. However, we have never observed a failure + ! of the assertion below as of 20220329. Why? + !-----------------------------------------! + call assert(nact > 0, 'NACT > 0', srname) ! + !-----------------------------------------! + if (nact == 0) then + exit + end if + !----------------------------------------------------------------------------------------------! +end do ! End of DO WHILE (NACT < N) + +! It is possible to have NACT == 0 here. The following lines improve the performance of LINCOA. +! Powell's code does not take care of this case explicitly. +if (nact == 0) then + qfac = eye(n) + psd = -g +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + ! During the development, we want to get alerted if ITER reaches MAXITER. + call assert(iter < maxiter, 'ITER < MAXITER', srname) + call assert(nact >= 0 .and. nact <= min(m, n), '0 <= NACT <= MIN(M, N)', srname)! Can NACT be 0? + call assert(size(iact) == m, 'SIZE(IACT) == M', srname) + call assert(all(iact(1:nact) >= 1 .and. iact(1:nact) <= m), '1 <= IACT <= M', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + call assert(isorth(qfac, tol), 'QFAC is orthogonal', srname) + call assert(size(rfac, 1) == n .and. size(rfac, 2) == n, 'SIZE(RFAC) == [N, N]', srname) + call assert(istriu(rfac), 'RFAC is upper triangular', srname) + call assert(size(psd) == n, 'SIZE(PSD) == N', srname) + ! PSD = -G when NACT == 0; G may contain Inf/NaN. + call assert(all(is_finite(psd)) .or. nact == 0, 'PSD is finite unless NACT == 0', srname) + ! In theory, ||PSD||^2 <= GG and -GG <= PSD^T*G <= 0. + ! N.B. 1. Do not use DD, which may not be up to date. 2. PSD^T*G can be NaN if G is huge. + call assert(inprod(psd, psd) <= TWO * gg, '||PSD||^2 <= 2*GG', srname) + call assert(.not. (inprod(psd, g) > 1.0E2_RP * EPS * gg .or. inprod(psd, g) < -TWO * gg), '-2*GG <= PSD^T*G <= 0', srname) +end if + +end subroutine getact + + +subroutine addact(l, c, iact, nact, qfac, resact, resnew, rfac, vlam) +!--------------------------------------------------------------------------------------------------! +! This subroutine adds the constraint with index L to the active set as the (NACT+ )-th active +! constraint, updates IACT, QFAC, etc accordingly, and increments NACT to NACT+1. Here, C is the +! gradient of the new active constraint. +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, EPS, TEN, MAXPOW10, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : istriu, isorth +use, non_intrinsic :: powalg_mod, only : qradd +implicit none + +! Inputs +integer(IK), intent(in) :: l +real(RP), intent(in) :: c(:) ! C(N) + +! In-outputs +integer(IK), intent(inout) :: iact(:) ! IACT(M) +integer(IK), intent(inout) :: nact +real(RP), intent(inout) :: qfac(:, :) ! QFAC(N, N) +real(RP), intent(inout) :: resact(:) ! RESACT(M) +real(RP), intent(inout) :: resnew(:) ! RESNEW(M) +real(RP), intent(inout) :: rfac(:, :) ! RFAC(N, N) +real(RP), intent(inout) :: vlam(:) ! VLAM(N) + +! Local variables (debugging only) +character(len=*), parameter :: srname = 'ADD_ACT' +integer(IK) :: m +integer(IK) :: n +integer(IK) :: nsave +real(RP) :: tol + +! Sizes +m = int(size(iact), kind(m)) +n = int(size(vlam), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= 1, 'M >= 1', srname) ! Should not be called when M == 0. + call assert(n >= 1, 'N >= 1', srname) + call assert(nact >= 0 .and. nact <= min(m, n) - 1_IK, '0 <= NACT <= MIN(M, N)-1', srname) + call assert(l >= 1 .and. l <= m, '1 <= L <= M', srname) + call assert(all(iact(1:nact) >= 1 .and. iact(1:nact) <= m), '1 <= IACT <= M', srname) + call assert(.not. any(iact(1:nact) == l), 'L is not in IACT(1:NACT)', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(8, MAXPOW10) * EPS * real(n, RP))) + call assert(isorth(qfac, tol), 'QFAC is orthogonal', srname) + call assert(size(rfac, 1) == n .and. size(rfac, 2) == n, 'SIZE(RFAC) == [N, N]', srname) + call assert(istriu(rfac), 'RFAC is upper triangular', srname) + call assert(size(resact) == m, 'SIZE(RESACT) == M', srname) + call assert(size(resnew) == m, 'SIZE(RESNEW) == M', srname) + nsave = nact ! For debugging only +end if + +!====================! +! Calculation starts ! +!====================! + +! QRADD applies Givens rotations to the last (N-NACT) columns of QFAC so that the first (NACT+1) +! columns of QFAC are the ones required for the addition of the L-th constraint, and add the +! appropriate column to RFAC. +! N.B.: QRADD always augment NACT by 1, which differs from the corresponding subroutine in COBYLA. +! It is ensured that C cannot be represented by the gradients of the existing active constraints. +call qradd(c, qfac, rfac, nact) ! NACT is increased by 1! +! Indeed, it suffices to pass RFAC(:, 1:NACT+1) to QRADD as follows. +! !call qradd(c, qfac, rfac(:, 1:nact + 1), nact) ! NACT is increased by 1! + +! Update IACT, RESACT, RESNEW, and VLAM. N.B.: NACT has been increased by 1 in QRADD. +iact(nact) = l +resact(nact) = resnew(l) ! RESACT(NACT) = RESNEW(IACT(NACT)) +resnew(l) = ZERO ! RESNEW(IACT(NACT)) = ZERO ! Why not TINYCV? See DECACT. +vlam(nact) = ZERO + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nact == nsave + 1, 'NACT = NSAVE + 1', srname) + call assert(nact >= 1 .and. nact <= min(m, n), '1 <= NACT <= MIN(M, N)', srname) + call assert(all(iact(1:nact) >= 1 .and. iact(1:nact) <= m), '1 <= IACT <= M', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + call assert(isorth(qfac, tol), 'QFAC is orthogonal', srname) + call assert(size(rfac, 1) == n .and. size(rfac, 2) == n, 'SIZE(RFAC) == [N, N]', srname) + call assert(istriu(rfac), 'RFAC is upper triangular', srname) + call assert(size(resact) == m, 'SIZE(RESACT) == M', srname) + call assert(size(resnew) == m, 'SIZE(RESNEW) == M', srname) +end if + +end subroutine addact + + +subroutine delact(icon, iact, nact, qfac, resact, resnew, rfac, vlam) +!--------------------------------------------------------------------------------------------------! +! This subroutine deletes the constraint with index IACT(ICON) from the active set, updates IACT, +! QFAC, etc accordingly, and reduces NACT to NACT-1. +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: consts_mod, only : RP, IK, EPS, TEN, MAXPOW10, TINYCV, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : isorth, istriu +use, non_intrinsic :: powalg_mod, only : qrexc +implicit none + +! Inputs +integer(IK), intent(in) :: icon + +! In-outputs +integer(IK), intent(inout) :: iact(:) ! IACT(M) +integer(IK), intent(inout) :: nact +real(RP), intent(inout) :: qfac(:, :) ! QFAC(N, N) +real(RP), intent(inout) :: resact(:) ! RESACT(M) +real(RP), intent(inout) :: resnew(:) ! RESNEW(M) +real(RP), intent(inout) :: rfac(:, :) ! RFAC(N, N) +real(RP), intent(inout) :: vlam(:) ! VLAM(N) + +! Local variables (debugging only) +character(len=*), parameter :: srname = 'DELACT' +integer(IK) :: l +integer(IK) :: m +integer(IK) :: n +integer(IK) :: nsave +real(RP) :: tol + +! Sizes +m = int(size(iact), kind(m)) +n = int(size(vlam), kind(n)) + +! Preconditions +! Preconditions +if (DEBUGGING) then + call assert(m >= 1, 'M >= 1', srname) ! Should not be called when M == 0. + call assert(n >= 1, 'N >= 1', srname) + call assert(nact >= 1 .and. nact <= min(m, n), '1 <= NACT <= MIN(M, N)', srname) + call assert(icon >= 1 .and. icon <= nact, '1 <= ICON <= NACT', srname) + call assert(all(iact(1:nact) >= 1 .and. iact(1:nact) <= m), '1 <= IACT <= M', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + tol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(8, MAXPOW10) * EPS * real(n, RP))) + call assert(isorth(qfac, tol), 'QFAC is orthogonal', srname) + call assert(size(rfac, 1) == n .and. size(rfac, 2) == n, 'SIZE(RFAC) == [N, N]', srname) + call assert(istriu(rfac), 'RFAC is upper triangular', srname) + call assert(size(resact) == m, 'SIZE(RESACT) == M', srname) + call assert(size(resnew) == m, 'SIZE(RESNEW) == M', srname) + nsave = nact ! For debugging only + l = iact(icon) ! For debugging only +end if + +!====================! +! Calculation starts ! +!====================! + +! The following instructions rearrange the active constraints so that the new value of IACT(NACT) is +! the old value of IACT(ICON). QREXC implements the updates of QFAC and RFAC by a sequence of Givens +! rotations. Then NACT is reduced by one. + +call qrexc(qfac, rfac(:, 1:nact), icon) ! QREXC does nothing if ICON == NACT. +! Indeed, it suffices to pass QFAC(:, 1:NACT) and RFAC(1:NACT, 1:NACT) to QREXC as follows. However, +! compilers may create a temporary copy of RFAC(1:NACT, 1:NACT), which is not contiguous in memory. +! !call qrexc(qfac(:, 1:nact), rfac(1:nact, 1:nact), icon) + +iact(icon:nact) = [iact(icon + 1:nact), iact(icon)] +resact(icon:nact) = [resact(icon + 1:nact), resact(icon)] +resnew(iact(nact)) = max(resact(nact), TINYCV) +vlam(icon:nact) = [vlam(icon + 1:nact), vlam(icon)] +nact = nact - 1_IK + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nact == nsave - 1, 'NACT = NSAVE - 1', srname) + call assert(nact >= 0 .and. nact <= min(m, n) - 1, '1 <= NACT <= MIN(M, N)-1', srname) + call assert(all(iact(1:nact) >= 1 .and. iact(1:nact) <= m), '1 <= IACT <= M', srname) + call assert(.not. any(iact(1:nact) == l), 'L is not in IACT(1:NACT)', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + call assert(isorth(qfac, tol), 'QFAC is orthogonal', srname) + call assert(size(rfac, 1) == n .and. size(rfac, 2) == n, 'SIZE(RFAC) == [N, N]', srname) + call assert(istriu(rfac), 'RFAC is upper triangular', srname) + call assert(size(resact) == m, 'SIZE(RESACT) == M', srname) + call assert(size(resnew) == m, 'SIZE(RESNEW) == M', srname) +end if + +end subroutine delact + + +end module getact_mod diff --git a/examples/fortran/prima/native/lincoa/initialize.f90 b/examples/fortran/prima/native/lincoa/initialize.f90 new file mode 100644 index 000000000..ab3a89a23 --- /dev/null +++ b/examples/fortran/prima/native/lincoa/initialize.f90 @@ -0,0 +1,421 @@ +! FIXME: The definitions of CVAL, FEASIBLE, and KOPT are questionable. + +module initialize_lincoa_mod +!--------------------------------------------------------------------------------------------------! +! This module performs the initialization of LINCOA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Tue 10 Feb 2026 02:41:49 PM CET +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: initxf, inith + + +contains + + +subroutine initxf(calfun, iprint, maxfun, Aeq, Aineq, amat, beq, bineq, ctol, ftarget, rhobeg, xl, xu,& + & x0, b, ij, kopt, nf, chist, cval, fhist, fval, xbase, xhist, xpt, evaluated, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine does the initialization about the interpolation points & their function values. +! +! N.B.: +! 1. Remark on IJ: +! If NPT <= 2*N + 1, then IJ is empty. Assume that NPT >= 2*N + 2. Then SIZE(IJ) = [2, NPT-2*N-1]. +! IJ contains integers between 1 and N. For each K > 2*N + 1, XPT(:, K) is +! XPT(:, IJ(1, K) + 1) + XPT(:, IJ(2, K) + 1). The 1 in IJ + 1 comes from the fact that XPT(:, 1) +! corresponds to the base point XBASE. Let I = IJ(1, K) and J = IJ(2, K). Then all the entries of +! XPT(:, K) are zero except for the I and J entries. Consequently, the Hessian of the quadratic +! model will get a possibly nonzero (I, J) entry. +! 2. At return, +! INFO = INFO_DFT: initialization finishes normally +! INFO = FTARGET_ACHIEVED: return because F <= FTARGET +! INFO = NAN_INF_X: return because X contains NaN +! INFO = NAN_INF_F: return because F is either NaN or +Inf +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, ZERO, EPS, TEN, MAXPOW10, REALMAX, BOUNDMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: evaluate_mod, only : evaluate +use, non_intrinsic :: history_mod, only : savehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT +use, non_intrinsic :: linalg_mod, only : matprod, maximum, eye, trueloc +use, non_intrinsic :: memory_mod, only : safealloc +use, non_intrinsic :: message_mod, only : fmsg +use, non_intrinsic :: pintrf_mod, only : OBJ +use, non_intrinsic :: powalg_mod, only : setij + +implicit none + +! Inputs +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfun +real(RP), intent(in) :: Aeq(:, :) ! AMAT(Meq, N) +real(RP), intent(in) :: Aineq(:, :) ! AMAT(Mineq, N) +real(RP), intent(in) :: amat(:, :) ! AMAT(N, M) +real(RP), intent(in) :: beq(:) ! Beq(M) +real(RP), intent(in) :: bineq(:) ! Bineq(M) +real(RP), intent(in) :: ctol +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: xl(:) ! XL(N) +real(RP), intent(in) :: xu(:) ! XU(N) +real(RP), intent(in) :: x0(:) ! X0(N) + +! In-outputs +real(RP), intent(inout) :: b(:) ! B(M) + +! Outputs +integer(IK), intent(out) :: info +integer(IK), intent(out) :: ij(:, :) ! IJ(2, MAX(0_IK, NPT-2*N-1)) +integer(IK), intent(out) :: kopt +integer(IK), intent(out) :: nf +logical, intent(out) :: evaluated(:) ! EVALUATED(NPT) +real(RP), intent(out) :: chist(:) ! CHIST(MAXCHIST) +real(RP), intent(out) :: cval(:) ! CVAL(NPT) +real(RP), intent(out) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out) :: fval(:) ! FVAL(NPT) +real(RP), intent(out) :: xbase(:) ! XBASE(N) +real(RP), intent(out) :: xhist(:, :) ! XHIST(N, MAXXHIST) +real(RP), intent(out) :: xpt(:, :) ! XPT(N, NPT) + +! Local variables +character(len=*), parameter :: solver = 'LINCOA' +character(len=*), parameter :: srname = 'INITXF' +integer(IK) :: k +integer(IK) :: m +integer(IK) :: maxchist +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: npt +integer(IK) :: subinfo +integer(IK), allocatable :: ixl(:) +integer(IK), allocatable :: ixu(:) +logical :: feasible(size(xpt, 2)) +real(RP) :: constr(count(xl > -BOUNDMAX) + count(xu < BOUNDMAX) + 2 * size(beq) + size(bineq)) +real(RP) :: constr_leq(size(beq)) +real(RP) :: cstrv +real(RP) :: f +real(RP) :: x(size(x0)) + +! Sizes. +m = int(size(b), kind(m)) +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxchist = int(size(chist), kind(maxchist)) +maxhist = int(max(maxxhist, maxfhist, maxchist), kind(maxhist)) + +! Preconditions +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(npt >= n + 2, 'NPT >= N+2', srname) + call assert(size(Aeq, 1) == size(beq) .and. size(Aeq, 2) == n, 'SIZE(Aeq) == [SIZE(Beq), M]', srname) + call assert(size(Aineq, 1) == size(bineq) .and. size(Aineq, 2) == n, 'SIZE(Aineq) == [SIZE(Bineq), M]', srname) + call assert(size(amat, 1) == n .and. size(amat, 2) == m, 'SIZE(AMAT) == [N, M]', srname) + call assert(rhobeg > 0, 'RHOBEG > 0', srname) + call assert(size(xbase) == n, 'SIZE(XBASE) == N', srname) + call assert(size(xl) == n .and. size(xu) == n, 'SIZE(XL) == N == SIZE(XU)', srname) + call assert(size(x0) == n .and. all(is_finite(x0)), 'SIZE(X0) == N, X0 is finite', srname) + call assert(size(fval) == npt, 'SIZE(FVAL) == NPT', srname) + call assert(size(cval) == npt, 'SIZE(CVAL) == NPT', srname) + call assert(size(evaluated) == npt, 'SIZE(EVALUATED) == NPT', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(maxchist * (maxchist - maxhist) == 0, 'SIZE(CHIST) == 0 or MAXHIST', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialize INFO to the default value. At return, an INFO different from this value will indicate +! an abnormal return. +info = INFO_DFT + +! Initialize XBASE to X0. +xbase = x0 + +! EVALUATED is a boolean array with EVALUATED(I) indicating whether the function value of the I-th +! interpolation point has been evaluated. We need it for a portable counting of the number of +! function evaluations, especially if the loop is conducted asynchronously. However, the loop here +! is not fully parallelizable if NPT>2N+1, as the definition XPT(;, 2N+2:end) involves FVAL(1:2N+1). +evaluated = .false. + +! Initialize XHIST, FHIST, CHIST, FVAL, and CVAL. Otherwise, compilers may complain that they are +! not (completely) initialized if the initialization aborts due to abnormality (see CHECKEXIT). +! N.B.: 1. Initializing them to NaN would be more reasonable (NaN is not available in Fortran). +! 2. Do not initialize the models if the current initialization aborts due to abnormality. Otherwise, +! errors or exceptions may occur, as FVAL and XPT etc are uninitialized. +xhist = -REALMAX +fhist = REALMAX +chist = REALMAX +fval = REALMAX +cval = REALMAX + +! Set the nonzero coordinates of XPT(K,.), K=1,2,...,min[2*N+1,NPT], but they may be altered +! later to make a constraint violation sufficiently large. +xpt(:, 1) = ZERO +xpt(:, 2:n + 1) = rhobeg * eye(n) +xpt(:, n + 2:npt) = -rhobeg * eye(n, npt - n - 1_IK) ! XPT(:, 2*N+2 : NPT) = ZERO if it is nonempty. + +! Set IJ. +! In general, when NPT = (N+1)*(N+2)/2, we can set IJ(:, 1 : NPT - (2*N+1)) to ANY permutation +! of {{I, J} : 1 <= I /= J <= N}; when NPT < (N+1)*(N+2)/2, we can set it to the first NPT - (2*N+1) +! elements of such a permutation. The following IJ is defined according to Powell's code. See also +! Section 3 of the NEWUOA paper and (2.4) of the BOBYQA paper. +ij = setij(n, npt) + +! Set XPT(:, 2*N + 2 : NPT). +! Indeed, XPT(:, K) has only two nonzeros for each K >= 2*N + 2, +! N.B.: The 1 in IJ + 1 comes from the fact that XPT(:, 1) corresponds to XBASE. +xpt(:, 2 * n + 2:npt) = xpt(:, ij(1, :) + 1) + xpt(:, ij(2, :) + 1) + +! Update the constraint right-hand sides to allow for the shift XBASE. +b = b - matprod(xbase, amat) + +! Define FEASIBLE, which will be used when defining KOPT. +do k = 1, npt + ! Internally, we use AMAT and B to evaluate the constraints. + cval(k) = maximum([ZERO, matprod(xpt(:, k), amat) - b]) + if (is_nan(cval(k))) then + cval(k) = REALMAX + end if + ! Powell's implementation contains the following procedure that shifts every infeasible point if + ! necessary so that its constraint violation is at least 0.2*RHOBEG. According to a test on + ! 20230209, it does not evidently improve the performance of LINCOA. Indeed, it worsens a bit the + ! performance in the early stage. Thus we decided to remove it. + !----------------------------------------------------------------------------------------------! + !mincv = 0.2_RP * rhobeg + !constr(1:m) = matprod(xpt(:, k), amat) - b + !if (cval(k) < mincv .and. cval(k) > 0) then + ! j = int(maxloc(constr(1:m), dim=1), kind(j)) + ! xpt(:, k) = xpt(:, k) + (mincv - constr(j)) * amat(:, j) + !end if + !----------------------------------------------------------------------------------------------! +end do +feasible = (cval <= 0) + +! Set FVAL by evaluating F. Totally parallelizable except for FMSG. +! IXL and IXU are the indices of the nontrivial lower and upper bounds, respectively. +call safealloc(ixl, int(count(xl > -BOUNDMAX), IK)) ! Removable in F2003. +call safealloc(ixu, int(count(xu < BOUNDMAX), IK)) ! Removable in F2003. +ixl = trueloc(xl > -BOUNDMAX) +ixu = trueloc(xu < BOUNDMAX) +do k = 1, npt + x = xbase + xpt(:, k) + call evaluate(calfun, x, f) + ! Evaluate the constraints. + constr_leq = matprod(Aeq, x) - beq + constr = [xl(ixl) - x(ixl), x(ixu) - xu(ixu), -constr_leq, constr_leq, matprod(Aineq, x) - bineq] + cstrv = maximum([ZERO, constr]) + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Initialization', iprint, k, rhobeg, f, x, cstrv, constr) + ! Save X, F, CSTRV into the history. + call savehist(k, x, xhist, f, fhist, cstrv, chist) + + evaluated(k) = .true. + cval(k) = cstrv ! CVAL will be used to initialize CFILT. + fval(k) = f + + ! Check whether to exit. + subinfo = checkexit(maxfun, k, cstrv, ctol, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if +end do + +! Deallocate IXL and IXU as they have finished their job. +deallocate (ixl, ixu) + +nf = int(count(evaluated), kind(nf)) +! Since the starting point is supposed to be feasible, there should be at least one feasible point. +! We set feasible to TRUE for the evaluated point with the smallest constraint violation. This is +! necessary, or KOPT defined below may become 0 if EVALUATED .AND. FEASIBLE is all FALSE. +feasible(minloc(cval, mask=evaluated, dim=1)) = .true. +kopt = int(minloc(fval, mask=(evaluated .and. feasible), dim=1), kind(kopt)) +!!MATLAB: +!!fopt = min(fval(evaluated & feasible)); +!!kopt = find(evaluated & feasible & ~(fval > fopt), 1, 'first'); + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(all(ij >= 1 .and. ij <= 2 * n), '1 <= IJ <= 2*N', srname) + call assert(all(ij(1, :) /= ij(2, :)), 'IJ(1, :) /= IJ(:, 2)', srname) + call assert(nf <= npt, 'NF <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= nf, '1 <= KOPT <= NF', srname) + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(cval) == npt .and. .not. any(evaluated .and. (is_nan(cval) .or. is_posinf(cval))), & + & 'SIZE(CVAL) == NPT and CVAL is not NaN or +Inf', srname) + call assert(size(fval) == npt .and. .not. any(evaluated .and. (is_nan(fval) .or. is_posinf(fval))), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(.not. any(evaluated .and. feasible .and. fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(size(chist) == maxchist, 'SIZE(CHIST) == MAXCHIST', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + ! LINCOA always starts with a feasible point. + if (m > 0) then + call assert(all(matprod(xpt(:, 1), amat) - b <= max(TEN**max(-12, -MAXPOW10), 1.0E2_RP * EPS) * & + & (ONE + sum(abs(xpt(:, 1))) + sum(abs(b)))), 'The starting point is feasible', srname) + end if +end if + +end subroutine initxf + + +subroutine inith(ij, xpt, idz, bmat, zmat, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine initializes [IDZ, BMAT, ZMAT] which represents the matrix H in (3.12) of the +! NEWUOA paper (see also (2.7) of the BOBYQA paper). +!--------------------------------------------------------------------------------------------------! +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, NAN_INF_MODEL +use, non_intrinsic :: linalg_mod, only : issymmetric, eye +!use, non_intrinsic :: powalg_mod, only : errh + +implicit none + +! Inputs +integer(IK), intent(in) :: ij(:, :) ! IJ(2, MAX(0_IK, NPT - 2_IK * N - 1_IK)) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +! N.B.: XPT is essentially only used for debugging, to test the error in the initial H. The initial +! ZMAT and BMAT are completely defined by RHOBEG and IJ. + +! Outputs +integer(IK), intent(out), optional :: info +integer(IK), intent(out) :: idz +real(RP), intent(out) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(out) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Local variables +character(len=*), parameter :: srname = 'INITH' +integer(IK) :: k +integer(IK) :: n +integer(IK) :: npt +real(RP) :: recip +real(RP) :: reciq +real(RP) :: rhobeg +real(RP) :: rhosq + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(all(ij >= 1 .and. ij <= 2 * n), '1 <= IJ <= 2*N', srname) + call assert(all(ij(1, :) /= ij(2, :)), 'IJ(1, :) /= IJ(2, :)', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +rhobeg = maxval(abs(xpt(:, 2))) ! Read RHOBEG from XPT. +rhosq = rhobeg**2 + +! Set BMAT. +recip = ONE / rhobeg +reciq = HALF / rhobeg +bmat = ZERO +if (npt <= 2 * n + 1) then + ! Set BMAT(1 : NPT-N-1, :) + bmat(1:npt - n - 1, 2:npt - n) = reciq * eye(npt - n - 1_IK) + bmat(1:npt - n - 1, n + 2:npt) = -reciq * eye(npt - n - 1_IK) + ! Set BMAT(NPT-N : N, :) + bmat(npt - n:n, 1) = -recip + bmat(npt - n:n, npt - n + 1:n + 1) = recip * eye(2_IK * n - npt + 1_IK) + bmat(npt - n:n, 2 * npt - n:npt + n) = -(HALF * rhosq) * eye(2_IK * n - npt + 1_IK) +else + bmat(:, 2:n + 1) = reciq * eye(n) + bmat(:, n + 2:2 * n + 1) = -reciq * eye(n) +end if + +! Set ZMAT. +recip = ONE / rhosq +reciq = sqrt(HALF) / rhosq +zmat = ZERO +if (npt <= 2 * n + 1) then + zmat(1, :) = -reciq - reciq + zmat(2:npt - n, :) = reciq * eye(npt - n - 1_IK) + zmat(n + 2:npt, :) = reciq * eye(npt - n - 1_IK) +else + ! Set ZMAT(:, 1:N). + zmat(1, 1:n) = -reciq - reciq + zmat(2:n + 1, 1:n) = reciq * eye(n) + zmat(n + 2:2 * n + 1, 1:n) = reciq * eye(n) + ! Set ZMAT(:, N+1 : NPT-N-1). + zmat(1, n + 1:npt - n - 1) = recip + zmat(2 * n + 2:npt, n + 1:npt - n - 1) = recip * eye(npt - 2_IK * n - 1_IK) + do k = 1, npt - 2_IK * n - 1_IK + zmat(ij(:, k) + 1, k + n) = -recip + end do +end if + +! Set IDZ. +idz = 1 + +if (present(info)) then + if (any(is_nan(bmat)) .or. any(is_nan(zmat))) then + info = NAN_INF_MODEL + else + info = INFO_DFT + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + !call assert(errh(idz, bmat, zmat, xpt) <= max(1.0E-3_RP, 1.0E2_RP * real(npt, RP) * EPS), & + ! & '[IDZ, BMA, ZMAT] represents H = W^{-1}', srname) +end if + +end subroutine inith + + +end module initialize_lincoa_mod diff --git a/examples/fortran/prima/native/lincoa/lincoa.f90 b/examples/fortran/prima/native/lincoa/lincoa.f90 new file mode 100644 index 000000000..82a2db4c0 --- /dev/null +++ b/examples/fortran/prima/native/lincoa/lincoa.f90 @@ -0,0 +1,786 @@ +module lincoa_mod +!--------------------------------------------------------------------------------------------------! +! LINCOA_MOD is a module providing the reference implementation of Powell's LINCOA algorithm. +! +! The algorithm approximately solves +! +! min F(X) subject to Aineq*X <= Bineq, Aeq*x = Beq, XL <= X <= XU, +! +! where X is a vector of variables that has N components, F is a real-valued objective function, +! Aineq is an Mineq-by-N matrix, Bineq is an Mineq-dimensional real vector, Aeq is an Meq-by-N +! matrix, Beq is an Meq-dimensional real vector, XL is an N-dimensional real vector, and XU is +! an N-dimensional real vector. +! +! It tackles the problem by a trust region method that forms quadratic models by interpolation. +! Usually there is much freedom in each new model after satisfying the interpolation conditions, +! which is taken up by minimizing the Frobenius norm of the change to the second derivative matrix +! of the model. One new function value is calculated on each iteration, usually at a point where +! the current model predicts a reduction in the least value so far of the objective function subject +! to the linear constraints. Alternatively, a new vector of variables may be chosen to replace an +! interpolation point that may be too far away for reliability, and the new point does not have to +! satisfy the constraints. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on the paper +! +! M. J. D. Powell, On fast trust region methods for quadratic models with linear constraints, +! Math. Program. Comput., 7:237--267, 2015 +! +! and Powell's code, with modernization, bug fixes, and improvements. +! +! N.B.: +! 1. Powell did not publish a paper to introduce the algorithm. The above paper does not describe +! LINCOA but discusses how to solve linearly-constrained trust-region subproblems. +! 2. Powell's code does not accept linear equality constraints or bound constraints. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Sunday, April 07, 2024 PM04:11:56 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: lincoa + + +contains + + +subroutine lincoa(calfun, x, & + & f, cstrv, & + & Aineq, bineq, & + & Aeq, beq, & + & xl, xu, & + & nf, rhobeg, rhoend, ftarget, ctol, cweight, maxfun, npt, iprint, eta1, eta2, gamma1, gamma2, & + & xhist, fhist, chist, maxhist, maxfilt, callback_fcn, info) +!--------------------------------------------------------------------------------------------------! +! Among all the arguments, only CALFUN, and X are obligatory. The others are OPTIONAL and you can +! neglect them unless you are familiar with the algorithm. Any unspecified optional input will take +! the default value detailed below. For instance, we may invoke the solver as follows. +! +! ! First define CALFUN and X, and then do the following. +! call lincoa(calfun, x, f) +! +! or +! +! ! First define CALFUN, X, Aineq, and Bineq, and then do the following. +! call lincoa(calfun, x, f, cstrv, Aineq = Aineq, bineq = bineq, rhobeg = 1.0D0, rhoend = 1.0D-6) +! +! See examples/lincoa_exmp.f90 for a concrete example. +! +! A detailed introduction to the arguments is as follows. +! N.B.: RP and IK are defined in the module CONSTS_MOD. See consts.F90 under the directory named +! "common". By default, RP = kind(0.0D0) and IK = kind(0), with REAL(RP) being the double-precision +! real, and INTEGER(IK) being the default integer. For ADVANCED USERS, RP and IK can be defined by +! setting PRIMA_REAL_PRECISION and PRIMA_INTEGER_KIND in common/ppf.h. Use the default if unsure. +! +! CALFUN +! Input, subroutine. +! CALFUN(X, F) should evaluate the objective function at the given REAL(RP) vector X and set the +! value to the REAL(RP) scalar F. It must be provided by the user, and its definition must conform +! to the following interface: +! !-------------------------------------------------------------------------! +! subroutine calfun(x, f) +! real(RP), intent(in) :: x(:) +! real(RP), intent(out) :: f +! end subroutine calfun +! !-------------------------------------------------------------------------! +! +! X +! Input and output, REAL(RP) vector. +! As an input, X should be an N dimensional vector that contains the starting point, N being the +! dimension of the problem. As an output, X will be set to an approximate minimizer. +! +! F +! Output, REAL(RP) scalar. +! F will be set to the objective function value of X at exit. +! +! CSTRV +! Output, REAL(RP) scalar. +! CSTRV will be set to the L-infinity constraint violation of X at exit, namely +! MAXVAL([0, Aineq*X - Bineq, abs(Aeq*X - Beq), XL - X, X - XU]) +! N.B.: We use the original constraints to evaluate CSTRV, even though they may be modified during +! the computation. +! +! Aineq, Bineq +! Input, REAL(RP) matrix of size [Mineq, N] and REAL vector of size Mineq unless they are both +! empty, default: [] and []. +! Aineq and Bineq represent the linear inequality constraints: Aineq*X <= Bineq. +! +! Aeq, Beq +! Input, REAL(RP) matrix of size [Meq, N] and REAL vector of size Meq unless they are both +! empty, default: [] and []. +! Aeq and Beq represent the linear equality constraints: Aeq*X = Beq. +! +! XL, XU +! Input, REAL(RP) vectors of size N unless they are both empty, default: [] and []. +! XL is the lower bound for X. Its size is either N or 0, the latter signifying that X has no +! lower bound. Any entry of XL that is NaN or below -BOUNDMAX will be taken as -BOUNDMAX, which +! effectively means there is no lower bound for the corresponding entry of X. The value of +! BOUNDMAX is 0.25*HUGE(X), which is about 8.6E37 for single precision and 4.5E307 for double +! precision. XU is similar. +! +! NF +! Output, INTEGER(IK) scalar. +! NF will be set to the number of calls of CALFUN at exit. +! +! RHOBEG, RHOEND +! Inputs, REAL(RP) scalars, default: RHOBEG = 1, RHOEND = 10^-6. RHOBEG and RHOEND must be set to +! the initial and final values of a trust-region radius, both being positive and RHOEND <= RHOBEG. +! Typically RHOBEG should be about one tenth of the greatest expected change to a variable, and +! RHOEND should indicate the accuracy that is required in the final values of the variables. +! +! FTARGET +! Input, REAL(RP) scalar, default: -Inf. +! FTARGET is the target function value. The algorithm will terminate when a point with a function +! value <= FTARGET is found. +! +! CTOL +! Input, REAL(RP) scalar, default: machine epsilon. +! CTOL is the tolerance of constraint violation. X is considered feasible if CSTRV(X) <= CTOL. +! N.B.: 1. CTOL is absolute, not relative. +! 2. CTOL is used for choosing the returned X. It does not affect the iterations of the algorithm. +! +! CWEIGHT +! Input, REAL(RP) scalar, default: CWEIGHT_DFT defined in the module CONSTS_MOD in common/consts.F90. +! CWEIGHT is the weight that the constraint violation takes in the selection of the returned X. +! +! MAXFUN +! Input, INTEGER(IK) scalar, default: MAXFUN_DIM_DFT*N with MAXFUN_DIM_DFT defined in the module +! CONSTS_MOD (see common/consts.F90). MAXFUN is the maximal number of calls of CALFUN. +! +! NPT +! Input, INTEGER(IK) scalar, default: 2N + 1. +! NPT is the number of interpolation conditions for each trust region model. Its value must be in +! the interval [N+2, (N+1)(N+2)/2]. Typical choices of Powell were NPT=N+6 and NPT=2*N+1. Powell +! commented that "larger values tend to be highly inefficient when the number of variables is +! substantial, due to the amount of work and extra difficulty of adjusting more points." +! +! IPRINT +! Input, INTEGER(IK) scalar, default: 0. +! The value of IPRINT should be set to 0, 1, -1, 2, -2, 3, or -3, which controls how much +! information will be printed during the computation: +! 0: there will be no printing; +! 1: a message will be printed to the screen at the return, showing the best vector of variables +! found and its objective function value; +! 2: in addition to 1, each new value of RHO is printed to the screen, with the best vector of +! variables so far and its objective function value; +! 3: in addition to 2, each function evaluation with its variables will be printed to the screen; +! -1, -2, -3: the same information as 1, 2, 3 will be printed, not to the screen but to a file +! named LINCOA_output.txt; the file will be created if it does not exist; the new output will +! be appended to the end of this file if it already exists. +! Note that IPRINT = +/-3 can be costly in terms of time and/or space. +! +! ETA1, ETA2, GAMMA1, GAMMA2 +! Input, REAL(RP) scalars, default: ETA1 = 0.1, ETA2 = 0.7, GAMMA1 = 0.5, and GAMMA2 = 2. +! ETA1, ETA2, GAMMA1, and GAMMA2 are parameters in the updating scheme of the trust-region radius +! detailed in the subroutine TRRAD in trustregion.f90. Roughly speaking, the trust-region radius +! is contracted by a factor of GAMMA1 when the reduction ratio is below ETA1, and enlarged by a +! factor of GAMMA2 when the reduction ratio is above ETA2. It is required that 0 < ETA1 <= ETA2 +! < 1 and 0 < GAMMA1 < 1 < GAMMA2. Normally, ETA1 <= 0.25. It is NOT advised to set ETA1 >= 0.5. +! +! XHIST, FHIST, CHIST, MAXHIST +! XHIST: Output, ALLOCATABLE rank 2 REAL(RP) array; +! FHIST: Output, ALLOCATABLE rank 1 REAL(RP) array; +! CHIST: Output, ALLOCATABLE rank 1 REAL(RP) array; +! MAXHIST: Input, INTEGER(IK) scalar, default: MAXFUN +! XHIST, if present, will output the history of iterates, while FHIST/CHIST, if present, will output +! the history function values/constraint violations. MAXHIST should be a nonnegative integer, and +! XHIST/FHIST/CHIST will output only the history of the last MAXHIST iterations. Therefore, +! MAXHIST = 0 means XHIST/FHIST/CHIST will output nothing, while setting MAXHIST = MAXFUN requests +! XHIST/FHIST/CHIST to output all the history. +! If XHIST is present, its size at exit will be [N, min(NF, MAXHIST)]; if FHIST/CHIST is present, +! its size at exit will be min(NF, MAXHIST). +! +! IMPORTANT NOTICE: +! Setting MAXHIST to a large value can be costly in terms of memory for large problems. +! MAXHIST will be reset to a smaller value if the memory needed exceeds MAXHISTMEM defined in +! CONSTS_MOD (see consts.F90 under the directory named "common"). +! Use *HIST with caution! (N.B.: the algorithm is NOT designed for large problems). +! +! CALLBACK_FCN +! Input, function to report progress and optionally request termination. +! +! INFO +! Output, INTEGER(IK) scalar. +! INFO is the exit flag. It will be set to one of the following values defined in the module +! INFOS_MOD (see common/infos.f90): +! SMALL_TR_RADIUS: the lower bound for the trust region radius is reached; +! FTARGET_ACHIEVED: the target function value is reached; +! MAXFUN_REACHED: the objective function has been evaluated MAXFUN times; +! MAXTR_REACHED: the trust region iteration has been performed MAXTR times (MAXTR = 2*MAXFUN); +! NAN_INF_MODEL: NaN or Inf occurs in the model; +! NAN_INF_X: NaN or Inf occurs in X; +! DAMAGING_ROUNDING: the rounding error becomes damaging; +! ZERO_LINEAR_CONSTRAINT: one of the linear constraints has a zero gradient +! !--------------------------------------------------------------------------! +! The following case(s) should NEVER occur unless there is a bug. +! NAN_INF_F: the objective function returns NaN or +Inf; +! TRSUBP_FAILED: a trust region step failed to reduce the model. +! !--------------------------------------------------------------------------! +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : DEBUGGING +use, non_intrinsic :: consts_mod, only : MAXFUN_DIM_DFT, MAXFILT_DFT, IPRINT_DFT +use, non_intrinsic :: consts_mod, only : RHOBEG_DFT, RHOEND_DFT, CTOL_DFT, CWEIGHT_DFT, FTARGET_DFT +use, non_intrinsic :: consts_mod, only : RP, IK, TWO, HALF, TEN, TENTH, EPS, BOUNDMAX +use, non_intrinsic :: debug_mod, only : assert, warning +use, non_intrinsic :: evaluate_mod, only : moderatex +use, non_intrinsic :: history_mod, only : prehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: linalg_mod, only : trueloc +use, non_intrinsic :: memory_mod, only : safealloc +use, non_intrinsic :: pintrf_mod, only : OBJ, CALLBACK +use, non_intrinsic :: preproc_mod, only : preproc +use, non_intrinsic :: selectx_mod, only : isbetter +use, non_intrinsic :: string_mod, only : num2str + +! Solver-specific modules +use, non_intrinsic :: lincob_mod, only : lincob + +implicit none + +! Compulsory arguments +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +real(RP), intent(inout) :: x(:) ! X(N) + +! Optional inputs +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in), optional :: iprint +integer(IK), intent(in), optional :: maxfilt +integer(IK), intent(in), optional :: maxfun +integer(IK), intent(in), optional :: maxhist +integer(IK), intent(in), optional :: npt +real(RP), intent(in), optional :: Aeq(:, :) ! Aeq(Meq, N) +real(RP), intent(in), optional :: Aineq(:, :) ! Aineq(Mineq, N) +real(RP), intent(in), optional :: beq(:) ! Beq(Meq) +real(RP), intent(in), optional :: bineq(:) ! Bineq(Mineq) +real(RP), intent(in), optional :: ctol +real(RP), intent(in), optional :: cweight +real(RP), intent(in), optional :: eta1 +real(RP), intent(in), optional :: eta2 +real(RP), intent(in), optional :: ftarget +real(RP), intent(in), optional :: gamma1 +real(RP), intent(in), optional :: gamma2 +real(RP), intent(in), optional :: rhobeg +real(RP), intent(in), optional :: rhoend +real(RP), intent(in), optional :: xl(:) ! XL(N) +real(RP), intent(in), optional :: xu(:) ! XU(N) + +! Optional outputs +integer(IK), intent(out), optional :: info +integer(IK), intent(out), optional :: nf +real(RP), intent(out), optional :: cstrv +real(RP), intent(out), optional :: f +real(RP), intent(out), optional, allocatable :: chist(:) ! CHIST(MAXCHIST) +real(RP), intent(out), optional, allocatable :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out), optional, allocatable :: xhist(:, :) ! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'LINCOA' +character(len=*), parameter :: srname = 'LINCOA' +integer(IK) :: info_loc +integer(IK) :: iprint_loc +integer(IK) :: maxfilt_loc +integer(IK) :: maxfun_loc +integer(IK) :: maxhist_loc +integer(IK) :: meq +integer(IK) :: mineq +integer(IK) :: n +integer(IK) :: nf_loc +integer(IK) :: nhist +integer(IK) :: npt_loc +real(RP) :: cstrv_loc +real(RP) :: ctol_loc +real(RP) :: cweight_loc +real(RP) :: eta1_loc +real(RP) :: eta2_loc +real(RP) :: f_loc +real(RP) :: ftarget_loc +real(RP) :: gamma1_loc +real(RP) :: gamma2_loc +real(RP) :: rhobeg_loc +real(RP) :: rhoend_loc +real(RP) :: xl_loc(size(x)) +real(RP) :: xu_loc(size(x)) +real(RP), allocatable :: Aeq_loc(:, :) ! Aeq_LOC(Meq, N) +real(RP), allocatable :: Aineq_loc(:, :) ! Aineq_LOC(Mineq, N) +real(RP), allocatable :: amat(:, :) ! AMAT(N, M); each column corresponds to a constraint +real(RP), allocatable :: beq_loc(:) ! Beq_LOC(Meq) +real(RP), allocatable :: bineq_loc(:) ! Bineq_LOC(Mineq) +real(RP), allocatable :: bvec(:) ! BVEC(M) +real(RP), allocatable :: chist_loc(:) ! CHIST_LOC(MAXCHIST) +real(RP), allocatable :: fhist_loc(:) ! FHIST_LOC(MAXFHIST) +real(RP), allocatable :: xhist_loc(:, :) ! XHIST_LOC(N, MAXXHIST) + +! Sizes +if (present(bineq)) then + mineq = int(size(bineq), kind(mineq)) +else + mineq = 0 +end if +if (present(beq)) then + meq = int(size(beq), kind(meq)) +else + meq = 0 +end if +n = int(size(x), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(mineq >= 0, 'Mineq >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(present(Aineq) .eqv. present(bineq), 'Aineq and Bineq are both present or both absent', srname) + if (present(Aineq)) then + call assert((size(Aineq, 1) == mineq .and. size(Aineq, 2) == n) & + & .or. (size(Aineq, 1) == 0 .and. size(Aineq, 2) == 0 .and. mineq == 0), & + & 'SIZE(Aineq) == [Mineq, N] unless Aineq and Bineq are both empty', srname) + end if + call assert(present(Aeq) .eqv. present(beq), 'Aeq and Beq are both present or both absent', srname) + if (present(Aeq)) then + call assert((size(Aeq, 1) == meq .and. size(Aeq, 2) == n) & + & .or. (size(Aeq, 1) == 0 .and. size(Aeq, 2) == 0 .and. meq == 0), & + & 'SIZE(Aeq) == [Meq, N] unless Aeq and Beq are both empty', srname) + end if + if (present(xl)) then + call assert(size(xl) == n .or. size(xl) == 0, 'SIZE(XL) == N unless XL is empty', srname) + end if + if (present(xu)) then + call assert(size(xu) == n .or. size(xu) == 0, 'SIZE(XU) == N unless XU is empty', srname) + end if +end if + +! Read the inputs + +x = moderatex(x) + +call safealloc(Aineq_loc, mineq, n) ! NOT removable even in F2003, as Aineq may be absent or of size 0-by-0. +if (present(Aineq) .and. mineq > 0) then + ! We must check Mineq > 0. Otherwise, the size of Aineq_LOC may be changed to 0-by-0 due to + ! automatic (re)allocation if that is the size of Aineq; we allow Aineq to be 0-by-0, but + ! Aineq_LOC should be n-by-0. + Aineq_loc = Aineq +end if + +call safealloc(bineq_loc, mineq) ! NOT removable even in F2003, as Bineq may be absent. +if (present(bineq)) then + bineq_loc = bineq +end if + +call safealloc(Aeq_loc, meq, n) ! NOT removable even in F2003, as Aeq may be absent or of size 0-by-0. +if (present(Aeq) .and. meq > 0) then + ! We must check Meq > 0. Otherwise, the size of Aeq_LOC may be changed to 0-by-0 due to + ! automatic (re)allocation if that is the size of Aeq; we allow Aeq to be 0-by-0, but + ! Aeq_LOC should be n-by-0. + Aeq_loc = Aeq +end if + +call safealloc(beq_loc, meq) ! NOT removable even in F2003, as Beq may be absent. +if (present(beq)) then + beq_loc = beq +end if + +xl_loc = -BOUNDMAX +if (present(xl)) then + if (size(xl) > 0) then + xl_loc = xl + end if +end if +xl_loc(trueloc(is_nan(xl_loc) .or. xl_loc < -BOUNDMAX)) = -BOUNDMAX + +xu_loc = BOUNDMAX +if (present(xu)) then + if (size(xu) > 0) then + xu_loc = xu + end if +end if +xu_loc(trueloc(is_nan(xu_loc) .or. xu_loc > BOUNDMAX)) = BOUNDMAX + +! If RHOBEG is present, then RHOBEG_LOC is a copy of RHOBEG; otherwise, RHOBEG_LOC takes the default +! value for RHOBEG, taking the value of RHOEND into account. Note that RHOEND is considered only if +! it is present and it is VALID (i.e., finite and positive). The other inputs are read similarly. +if (present(rhobeg)) then + rhobeg_loc = rhobeg +elseif (present(rhoend)) then + ! Fortran does not take short-circuit evaluation of logic expressions. Thus it is WRONG to + ! combine the evaluation of PRESENT(RHOEND) and the evaluation of IS_FINITE(RHOEND) as + ! "IF (PRESENT(RHOEND) .AND. IS_FINITE(RHOEND))". The compiler may choose to evaluate the + ! IS_FINITE(RHOEND) even if PRESENT(RHOEND) is false! + if (is_finite(rhoend) .and. rhoend > 0) then + rhobeg_loc = max(TEN * rhoend, RHOBEG_DFT) + else + rhobeg_loc = RHOBEG_DFT + end if +else + rhobeg_loc = RHOBEG_DFT +end if + +if (present(rhoend)) then + rhoend_loc = rhoend +elseif (rhobeg_loc > 0) then + rhoend_loc = max(EPS, min((RHOEND_DFT / RHOBEG_DFT) * rhobeg_loc, RHOEND_DFT)) +else + rhoend_loc = RHOEND_DFT +end if + +if (present(ctol)) then + ctol_loc = ctol +else + ctol_loc = CTOL_DFT +end if + +if (present(cweight)) then + cweight_loc = cweight +else + cweight_loc = CWEIGHT_DFT +end if + +if (present(ftarget)) then + ftarget_loc = ftarget +else + ftarget_loc = FTARGET_DFT +end if + +if (present(maxfun)) then + maxfun_loc = maxfun +else + maxfun_loc = MAXFUN_DIM_DFT * n +end if + +if (present(npt)) then + npt_loc = npt +elseif (maxfun_loc >= n + 3_IK) then ! Take MAXFUN into account if it is valid. + npt_loc = min(maxfun_loc - 1_IK, 2_IK * n + 1_IK) +else + npt_loc = 2_IK * n + 1_IK +end if + +if (present(iprint)) then + iprint_loc = iprint +else + iprint_loc = IPRINT_DFT +end if + +if (present(eta1)) then + eta1_loc = eta1 +elseif (present(eta2)) then + if (eta2 > 0 .and. eta2 < 1) then + eta1_loc = max(EPS, eta2 / 7.0_RP) + end if +else + eta1_loc = TENTH +end if + +if (present(eta2)) then + eta2_loc = eta2 +elseif (eta1_loc > 0 .and. eta1_loc < 1) then + eta2_loc = (eta1_loc + TWO) / 3.0_RP +else + eta2_loc = 0.7_RP +end if + +if (present(gamma1)) then + gamma1_loc = gamma1 +else + gamma1_loc = HALF +end if + +if (present(gamma2)) then + gamma2_loc = gamma2 +else + gamma2_loc = TWO +end if + +if (present(maxhist)) then + maxhist_loc = maxhist +else + maxhist_loc = maxval([maxfun_loc, n + 3_IK, MAXFUN_DIM_DFT * n]) +end if + +if (present(maxfilt)) then + maxfilt_loc = maxfilt +else + maxfilt_loc = MAXFILT_DFT +end if + +! Preprocess the inputs in case some of them are invalid. It does nothing if all inputs are valid. +call preproc(solver, n, iprint_loc, maxfun_loc, maxhist_loc, ftarget_loc, rhobeg_loc, rhoend_loc, & + & npt=npt_loc, ctol=ctol_loc, cweight=cweight_loc, eta1=eta1_loc, eta2=eta2_loc, gamma1=gamma1_loc, & + & gamma2=gamma2_loc, maxfilt=maxfilt_loc) + +! Further revise MAXHIST_LOC according to MAXHISTMEM, and allocate memory for the history. +! In MATLAB/Python/Julia/R implementation, we should simply set MAXHIST = MAXFUN and initialize +! CHIST = NaN(1, MAXFUN), FHIST = NaN(1, MAXFUN), XHIST = NaN(N, MAXFUN) +! if they are requested; replace MAXFUN with 0 for the history that is not requested. +call prehist(maxhist_loc, n, present(xhist), xhist_loc, present(fhist), fhist_loc, present(chist), chist_loc) + +! Wrap the linear and bound constraints into a single constraint: AMAT^T*X <= BVEC. +call get_lincon(Aeq_loc, Aineq_loc, beq_loc, bineq_loc, rhoend_loc, xl_loc, xu_loc, x, amat, bvec) + +!-------------------- Call LINCOB, which performs the real calculations. --------------------------! +if (present(callback_fcn)) then + call lincob(calfun, iprint_loc, maxfilt_loc, maxfun_loc, npt_loc, Aeq_loc, Aineq_loc, amat, & + & beq_loc, bineq_loc, bvec, ctol_loc, cweight_loc, eta1_loc, eta2_loc, ftarget_loc, gamma1_loc, & + & gamma2_loc, rhobeg_loc, rhoend_loc, xl_loc, xu_loc, x, nf_loc, chist_loc, cstrv_loc, & + & f_loc, fhist_loc, xhist_loc, info_loc, callback_fcn) +else + call lincob(calfun, iprint_loc, maxfilt_loc, maxfun_loc, npt_loc, Aeq_loc, Aineq_loc, amat, & + & beq_loc, bineq_loc, bvec, ctol_loc, cweight_loc, eta1_loc, eta2_loc, ftarget_loc, gamma1_loc, & + & gamma2_loc, rhobeg_loc, rhoend_loc, xl_loc, xu_loc, x, nf_loc, chist_loc, cstrv_loc, & + & f_loc, fhist_loc, xhist_loc, info_loc) +end if +!--------------------------------------------------------------------------------------------------! + +! Deallocate variables not needed any more. We prefer explicit deallocation to the automatic one. +deallocate (Aineq_loc, Aeq_loc, amat, bineq_loc, beq_loc, bvec) + + +! Write the outputs. + +if (present(f)) then + f = f_loc +end if + +if (present(cstrv)) then + cstrv = cstrv_loc +end if + +if (present(nf)) then + nf = nf_loc +end if + +if (present(info)) then + info = info_loc +end if + +! Copy XHIST_LOC to XHIST if needed. +if (present(xhist)) then + nhist = min(nf_loc, int(size(xhist_loc, 2), kind(nhist))) + !----------------------------------------------------! + call safealloc(xhist, n, nhist) ! Removable in F2003. + !----------------------------------------------------! + xhist = xhist_loc(:, 1:nhist) + ! N.B.: + ! 0. Allocate XHIST as long as it is present, even if the size is 0; otherwise, it will be + ! illegal to enquire XHIST after exit. + ! 1. Even though Fortran 2003 supports automatic (re)allocation of allocatable arrays upon + ! intrinsic assignment, we keep the line of SAFEALLOC, because some very new compilers (Absoft + ! Fortran 21.0) are still not standard-compliant in this respect. + ! 2. NF may not be present. Hence we should NOT use NF but NF_LOC. + ! 3. When SIZE(XHIST_LOC, 2) > NF_LOC, which is the normal case in practice, XHIST_LOC contains + ! GARBAGE in XHIST_LOC(:, NF_LOC + 1 : END). Therefore, we MUST cap XHIST at NF_LOC so that + ! XHIST contains only valid history. For this reason, there is no way to avoid allocating + ! two copies of memory for XHIST unless we declare it to be a POINTER instead of ALLOCATABLE. +end if +! F2003 automatically deallocate local ALLOCATABLE variables at exit, yet we prefer to deallocate +! them immediately when they finish their jobs. +deallocate (xhist_loc) + +! Copy FHIST_LOC to FHIST if needed. +if (present(fhist)) then + nhist = min(nf_loc, int(size(fhist_loc), kind(nhist))) + !--------------------------------------------------! + call safealloc(fhist, nhist) ! Removable in F2003. + !--------------------------------------------------! + fhist = fhist_loc(1:nhist) ! The same as XHIST, we must cap FHIST at NF_LOC. +end if +deallocate (fhist_loc) + +! Copy CHIST_LOC to CHIST if needed. +if (present(chist)) then + nhist = min(nf_loc, int(size(chist_loc), kind(nhist))) + !--------------------------------------------------! + call safealloc(chist, nhist) ! Removable in F2003. + !--------------------------------------------------! + chist = chist_loc(1:nhist) ! The same as XHIST, we must cap CHIST at NF_LOC. +end if +deallocate (chist_loc) + +! If NF_LOC > MAXHIST_LOC, warn that not all history is recorded. +if ((present(xhist) .or. present(fhist) .or. present(chist)) .and. maxhist_loc < nf_loc) then + call warning(solver, 'Only the history of the last '//num2str(maxhist_loc)//' function evaluation(s) is recorded') +end if + +! Postconditions +if (DEBUGGING) then + call assert(nf_loc <= maxfun_loc, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + nhist = min(nf_loc, maxhist_loc) + if (present(xhist)) then + call assert(size(xhist, 1) == n .and. size(xhist, 2) == nhist, 'SIZE(XHIST) == [N, NHIST]', srname) + call assert(.not. any(is_nan(xhist)), 'XHIST does not contain NaN', srname) + end if + if (present(fhist)) then + call assert(size(fhist) == nhist, 'SIZE(FHIST) == NHIST', srname) + call assert(.not. any(is_nan(fhist) .or. is_posinf(fhist)), 'FHIST does not contain NaN/+Inf', srname) + end if + if (present(chist)) then + call assert(size(chist) == nhist, 'SIZE(CHIST) == NHIST', srname) + call assert(.not. any(is_nan(chist) .or. is_posinf(chist)), 'CHIST does not contain NaN/+Inf', srname) + end if + if (present(fhist) .and. present(chist)) then + call assert(.not. any(isbetter(fhist(1:nhist), chist(1:nhist), f_loc, cstrv_loc, ctol_loc)),& + & 'No point in the history is better than X', srname) + end if +end if + +end subroutine lincoa + + +subroutine get_lincon(Aeq, Aineq, beq, bineq, rhoend, xl, xu, x0, amat, bvec) +!--------------------------------------------------------------------------------------------------! +! This subroutine wraps the linear and bound constraints into a single constraint: AMAT^T*X <= BVEC. +! N.B.: +! 1. LINCOA modifies the right hand sides of the constraints to make the starting point feasible if +! it is not. This is not ideal, but Powell's code was implemented in this way. In the +! MATLAB/Python/Julia/R code, we should include a preprocessing subroutine to project the starting +! point to the feasible region if it is infeasible, so that the modification will not occur. +! 2. The linear inequality constraints received by LINCOB is AMAT^T * X <= BVEC. Note that Each +! column of AMAT corresponds to a constraint. This is different from Aineq and Aeq, whose rows +! correspond to constraints. AMAT is defined in this way because it is accessed in columns during +! the computation, and because Fortran saves arrays in the column-major order. In Python/C +! implementations, AMAT should be transposed. +! 3. LINCOA normalizes the linear constraints so that each constraint has a gradient of norm 1. This +! is essential for LINCOA. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, EPS, TEN, MAXPOW10, BOUNDMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert, warning +use, non_intrinsic :: linalg_mod, only : matprod, eye, trueloc +use, non_intrinsic :: memory_mod, only : safealloc + +implicit none + +! Inputs +real(RP), intent(in) :: Aeq(:, :) +real(RP), intent(in) :: Aineq(:, :) +real(RP), intent(in) :: beq(:) +real(RP), intent(in) :: bineq(:) +real(RP), intent(in) :: rhoend +real(RP), intent(in) :: xl(:) +real(RP), intent(in) :: xu(:) +real(RP), intent(in) :: x0(:) + +! Outputs +real(RP), intent(out), allocatable :: amat(:, :) +real(RP), intent(out), allocatable :: bvec(:) + +! Local variables +character(len=*), parameter :: solver = 'LINCOA' +character(len=*), parameter :: srname = 'GET_LINCON' +integer(IK) :: m +integer(IK) :: meq +integer(IK) :: mineq +integer(IK) :: mxl +integer(IK) :: mxu +integer(IK) :: n +integer(IK), allocatable :: ieq(:) +integer(IK), allocatable :: iineq(:) +integer(IK), allocatable :: ixl(:) +integer(IK), allocatable :: ixu(:) +logical :: constr_modified +real(RP) :: Aeq_norm(size(Aeq, 1)) +real(RP) :: Aeqx0(size(Aeq, 1)) +real(RP) :: Aineq_norm(size(Aineq, 1)) +real(RP) :: Aineqx0(size(Aineq, 1)) +real(RP) :: idmat(size(x0), size(x0)) +real(RP) :: smallx +real(RP), allocatable :: Anorm(:) + +! Sizes +n = int(size(x0), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(Aineq, 1) == size(bineq) .and. size(Aineq, 2) == n, 'SIZE(AINEQ) == [SIZE(BINEQ), N]', srname) + call assert(size(Aeq, 1) == size(beq) .and. size(Aeq, 2) == n, 'SIZE(AEQ) == [SIZE(BEQ), N]', srname) + call assert(size(xl) == n .and. size(xu) == n, 'SIZE(XL) == SIZE(XU) == N', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Decide the number of nontrivial and valid (gradient is nonzero) constraints. +mxl = int(count(xl > -BOUNDMAX), kind(mxl)) +mxu = int(count(xu < BOUNDMAX), kind(mxu)) +Aeq_norm = sqrt(sum(Aeq**2, dim=2)) +meq = int(count(Aeq_norm > 0), kind(meq)) +Aineq_norm = sqrt(sum(Aineq**2, dim=2)) +mineq = int(count(Aineq_norm > 0), kind(mineq)) +m = mxl + mxu + 2_IK * meq + mineq ! The final number of linear inequality constraints. + +! Print a warning if some constraints are invalid. They will be ignored (Powell's code would stop). +if (meq < size(Aeq, 1) .or. mineq < size(Aineq, 1)) then + call warning(solver, 'Some linear constraints have zero gradients; they are ignored') +end if + +! Allocate memory. Removable in F2003. +call safealloc(ixl, mxl) +call safealloc(ixu, mxu) +call safealloc(ieq, meq) +call safealloc(iineq, mineq) +call safealloc(amat, n, m) +call safealloc(bvec, m) +call safealloc(Anorm, 2_IK * meq + mineq) + +! Define the indices of the valid and nontrivial constraints. +ixl = trueloc(xl > -BOUNDMAX) +ixu = trueloc(xu < BOUNDMAX) +ieq = trueloc(Aeq_norm > 0) +iineq = trueloc(Aineq_norm > 0) + +! Wrap the linear constraints. +! The bound constraint XL <= X <= XU is handled as two constraints -X <= -XL, X <= XU. +! The equality constraint Aeq*X = Beq is handled as two constraints -Aeq*X <= -Beq, Aeq*X <= Beq. +! N.B.: +! 1. The treatment of the equality constraints is naive. One may choose to eliminate them instead. +! 2. The code below is quite inefficient in terms of memory, but we prefer readability. +idmat = eye(n, n) +amat = reshape(shape=shape(amat), source= & + & [-idmat(:, ixl), idmat(:, ixu), -transpose(Aeq(ieq, :)), transpose(Aeq(ieq, :)), transpose(Aineq(iineq, :))]) +bvec = [-xl(ixl), xu(ixu), -beq(ieq), beq(ieq), bineq(iineq)] +!!MATLAB code: +!!amat = [-idmat(:, ixl), idmat(:, ixu), -Aeq(ieq, :)', Aeq(ieq, :)', Aineq(iineq, :)']; +!!bvec = [-xl(ixl); xu(ixu); -beq(ieq); beq(ieq); bineq(iineq)]; + +! Modify BVEC if necessary so that the initial point is feasible. +Aeqx0 = matprod(Aeq, x0) +Aineqx0 = matprod(Aineq, x0) +bvec = max(bvec, [-x0(ixl), x0(ixu), -Aeqx0(ieq), Aeqx0(ieq), Aineqx0(iineq)]) + +! Normalize the linear constraints so that each constraint has a gradient of norm 1. +Anorm = [Aeq_norm(ieq), Aeq_norm(ieq), Aineq_norm(iineq)] +amat(:, mxl + mxu + 1:m) = amat(:, mxl + mxu + 1:m) / spread(Anorm, dim=1, ncopies=n) +bvec(mxl + mxu + 1:m) = bvec(mxl + mxu + 1:m) / Anorm + +! Deallocate memory. +deallocate (ixl, ixu, ieq, iineq, Anorm) + +! Print a warning if the starting point is sufficiently infeasible and the constraints are modified. +smallx = TEN**max(-6, -MAXPOW10) * rhoend +constr_modified = (any(x0 + smallx < xl) .or. any(x0 - smallx > xu) .or. & + & any(abs(Aeqx0 - beq) > smallx * Aeq_norm) .or. any(Aineqx0 - bineq > smallx * Aineq_norm)) +if (constr_modified) then + call warning(solver, 'The starting point is infeasible. '//solver// & + & ' modified the right-hand sides of the constraints to make it feasible') +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(amat, 1) == size(x0) .and. size(amat, 2) == size(bvec), & + & 'SIZE(AMAT) == [SIZE(X), SIZE(BVEC)]', srname) + call assert(all(matprod(x0, amat) - bvec <= max(TEN**max(-12, -MAXPOW10), 1.0E2_RP * EPS) * & + & (ONE + sum(abs(x0)) + sum(abs(bvec)))), 'The starting point is feasible', srname) +end if +end subroutine get_lincon + + +end module lincoa_mod diff --git a/examples/fortran/prima/native/lincoa/lincob.f90 b/examples/fortran/prima/native/lincoa/lincob.f90 new file mode 100644 index 000000000..a148ce94f --- /dev/null +++ b/examples/fortran/prima/native/lincoa/lincob.f90 @@ -0,0 +1,763 @@ +!TODO: +! 1. Check whether it is possible to change the definition of RESCON, RESNEW, RESTMP, RESACT so that +! we do not need to encode information into their signs. +! +module lincob_mod +!--------------------------------------------------------------------------------------------------! +! This module performs the major calculations of LINCOA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the paper +! +! M. J. D. Powell, On fast trust region methods for quadratic models with linear constraints, +! Math. Program. Comput., 7:237--267, 2015 +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Wed 08 Apr 2026 06:38:26 PM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: lincob + + +contains + + +subroutine lincob(calfun, iprint, maxfilt, maxfun, npt, Aeq, Aineq, amat, beq, bineq, bvec, & + & ctol, cweight, eta1, eta2, ftarget, gamma1, gamma2, rhobeg, rhoend, xl, xu, x, nf, chist, & + & cstrv, f, fhist, xhist, info, callback_fcn) +!--------------------------------------------------------------------------------------------------! +! This subroutine performs the actual calculations of LINCOA. +! +! The arguments IPRINT, MAXFILT, MAXFUN, MAXHIST, NPT, AEQ, AINEQ, BEQ, BINEQ, CTOL, CWEIGHT, ETA1, +! ETA2, FTARGET, GAMMA1, GAMMA2, RHOBEG, RHOEND, X, NF, F, XHIST, FHIST, CHIST, CSTRV and INFO are +! identical to the corresponding arguments in subroutine LINCOA. +! AMAT is a matrix whose columns are the constraint gradients, scaled so that they have unit length. +! BVEC contains on entry the right hand sides of the constraints, scaled as above. +! XBASE holds a shift of origin that should reduce the contributions from rounding errors to values +! of the model and Lagrange functions. +! XOPT is the displacement from XBASE of the feasible vector of variables that provides the least +! calculated F so far, this vector being the current trust region centre. FOPT = F(XOPT + XBASE). +! However, we do not save XOPT and FOPT explicitly, because XOPT = XPT(:, KOPT) and +! FOPT = FVAL(KOPT), which is explained below. +! [XPT, FVAL, KOPT] describes the interpolation set: +! XPT contains the interpolation points relative to XBASE, each COLUMN for a point; FVAL holds the +! values of F at the interpolation points; KOPT is the index of XOPT in XPT. +! [GOPT, HQ, PQ] describes the quadratic model: GOPT will hold the gradient of the quadratic model +! at XBASE + XOPT; HQ will hold the explicit second order derivatives of the quadratic model; PQ +! will contain the parameters of the implicit second order derivatives of the quadratic model. +! [BMAT, ZMAT, IDZ] describes the matrix H in the NEWUOA paper (eq. 3.12), which is the inverse of +! the coefficient matrix of the KKT system for the least-Frobenius norm interpolation problem: +! ZMAT will hold a factorization of the leading NPT*NPT submatrix of H, the factorization being +! ZMAT*Diag(DZ)*ZMAT^T with DZ(1:IDZ-1)=-1, DZ(IDZ:NPT-N-1)=1. BMAT will hold the last N ROWs of H +! except for the (NPT+1)th column. Note that the (NPT + 1)th row and column of H are not saved as +! they are unnecessary for the calculation. +! D is reserved for trial steps from XOPT. It is chosen by subroutine TRSTEP or GEOSTEP. Usually +! XBASE + XOPT + D is the vector of variables for the next call of CALFUN. +! IACT is an integer array for the indices of the active constraints. +! RESCON holds information about the constraint residuals at the current trust region center XOPT. +! 1. If if B(J) - AMAT(:, J)^T*XOPT <= DELTA, then RESCON(J) = B(J) - AMAT(:, J)^T*XOPT. Note that +! RESCON >= 0 in this case, because the algorithm keeps XOPT to be feasible. +! 2. Otherwise, RESCON(J) is a negative value that B(J) - AMAT(:,J)^T*XOPT >= |RESCON(J)| >= DELTA. +! RESCON can be updated without calculating the constraints that are far from being active, so +! that we only need to evaluate the constraints that are nearly active. +! QFAC is the orthogonal part of the QR factorization of the matrix of active constraint gradients, +! these gradients being ordered in accordance with IACT. When NACT is less than N, columns are +! appended to QFAC to complete an N by N orthogonal matrix, which is important for keeping +! calculated steps sufficiently close to the boundaries of the active constraints. +! RFAC is the upper triangular part of this QR factorization. +!--------------------------------------------------------------------------------------------------! + +! Generic models +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, HALF, TENTH, REALMAX, BOUNDMAX, MIN_MAXFILT, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: evaluate_mod, only : evaluate +use, non_intrinsic :: history_mod, only : savehist, rangehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, MAXTR_REACHED, SMALL_TR_RADIUS, CALLBACK_TERMINATE, NAN_INF_MODEL +use, non_intrinsic :: linalg_mod, only : matprod, maximum, eye, trueloc, linspace, norm, trueloc +use, non_intrinsic :: memory_mod, only : safealloc +use, non_intrinsic :: message_mod, only : fmsg, rhomsg, retmsg +use, non_intrinsic :: pintrf_mod, only : OBJ, CALLBACK +use, non_intrinsic :: powalg_mod, only : quadinc, omega_mul, hess_mul, updateh +use, non_intrinsic :: ratio_mod, only : redrat +use, non_intrinsic :: redrho_mod, only : redrho +use, non_intrinsic :: selectx_mod, only : savefilt, selectx, isbetter +use, non_intrinsic :: shiftbase_mod, only : shiftbase + +! Solver-specific modules +use, non_intrinsic :: geometry_lincoa_mod, only : geostep, setdrop_tr +use, non_intrinsic :: initialize_lincoa_mod, only : initxf, inith +use, non_intrinsic :: trustregion_lincoa_mod, only : trstep, trrad +use, non_intrinsic :: update_lincoa_mod, only : updatexf, updateq, tryqalt, updateres + +implicit none + +! Inputs +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfilt +integer(IK), intent(in) :: maxfun +integer(IK), intent(in) :: npt +real(RP), intent(in) :: Aeq(:, :) ! Aeq(Meq, N) +real(RP), intent(in) :: Aineq(:, :) ! Aineq(Mineq, N) +real(RP), intent(in) :: amat(:, :) ! AMAT(N, M) +real(RP), intent(in) :: beq(:) ! Beq(Meq) +real(RP), intent(in) :: bineq(:) ! Bineq(Mineq) +real(RP), intent(in) :: bvec(:) ! BVEC(M) +real(RP), intent(in) :: ctol +real(RP), intent(in) :: cweight +real(RP), intent(in) :: eta1 +real(RP), intent(in) :: eta2 +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: gamma1 +real(RP), intent(in) :: gamma2 +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: rhoend +real(RP), intent(in) :: xl(:) +real(RP), intent(in) :: xu(:) + +! In-outputs +real(RP), intent(inout) :: x(:) ! X(N) + +! Outputs +integer(IK), intent(out) :: info +integer(IK), intent(out) :: nf +real(RP), intent(out) :: chist(:) ! CHIST(MAXCHIST) +real(RP), intent(out) :: cstrv +real(RP), intent(out) :: f +real(RP), intent(out) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out) :: xhist(:, :) ! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'LINCOA' +character(len=*), parameter :: srname = 'LINCOB' +integer(IK) :: iact(size(bvec)) +integer(IK) :: idz +integer(IK) :: ij(2, max(0_IK, int(npt - 2 * size(x) - 1, IK))) +integer(IK) :: k +integer(IK) :: knew_geo +integer(IK) :: knew_tr +integer(IK) :: kopt +integer(IK) :: m +integer(IK) :: maxchist +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxtr +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: nact +integer(IK) :: nfilt +integer(IK) :: ngetact +integer(IK) :: nhist +integer(IK) :: subinfo +integer(IK) :: tr +integer(IK), allocatable :: ixl(:) +integer(IK), allocatable :: ixu(:) +logical :: accurate_mod +logical :: adequate_geo +logical :: bad_trstep +logical :: close_itpset +logical :: evaluated(npt) +logical :: feasible +logical :: improve_geo +logical :: qalt_better(3) +logical :: reduce_rho +logical :: shortd +logical :: small_trrad +logical :: terminate +logical :: trfail +logical :: ximproved +real(RP) :: b(size(bvec)) +real(RP) :: bmat(size(x), npt + size(x)) +real(RP) :: cfilt(maxfilt) +real(RP) :: constr(count(xl > -BOUNDMAX) + count(xu < BOUNDMAX) + 2 * size(beq) + size(bineq)) +real(RP) :: constr_leq(size(beq)) +real(RP) :: cval(npt) +real(RP) :: d(size(x)) +real(RP) :: delbar +real(RP) :: delta +real(RP) :: distsq(npt) +real(RP) :: dnorm +real(RP) :: dnorm_rec(3) ! Powell's implementation: DNORM_REC(5) +real(RP) :: ffilt(maxfilt) +real(RP) :: fval(npt) +real(RP) :: galt(size(x)) +real(RP) :: gamma3 +real(RP) :: gopt(size(x)) +real(RP) :: hq(size(x), size(x)) +real(RP) :: moderr +real(RP) :: moderr_alt +real(RP) :: pq(npt) +real(RP) :: pqalt(npt) +real(RP) :: qfac(size(x), size(x)) +real(RP) :: qred +real(RP) :: ratio +real(RP) :: rescon(size(bvec)) +real(RP) :: rfac(size(x), size(x)) +real(RP) :: rho +real(RP) :: xbase(size(x)) +real(RP) :: xdrop(size(x)) +real(RP) :: xfilt(size(x), maxfilt) +real(RP) :: xosav(size(x)) +real(RP) :: xpt(size(x), npt) +real(RP) :: zmat(npt, npt - size(x) - 1) +real(RP), parameter :: trtol = 1.0E-2_RP ! Convergence tolerance of trust-region subproblem solver + +! Sizes. +m = int(size(bvec), kind(m)) +n = int(size(x), kind(n)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxchist = int(size(chist), kind(maxchist)) +maxhist = int(max(maxxhist, maxfhist, maxchist), kind(maxhist)) + +! Preconditions +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(npt >= n + 2, 'NPT >= N+2', srname) + call assert(maxfun >= npt + 1, 'MAXFUN >= NPT+1', srname) + call assert(size(Aeq, 1) == size(beq) .and. size(Aeq, 2) == n, 'SIZE(Aeq) == [SIZE(Beq), N]', srname) + call assert(size(Aineq, 1) == size(bineq) .and. size(Aineq, 2) == n, 'SIZE(Aineq) == [SIZE(Bineq), N]', srname) + call assert(size(amat, 1) == n .and. size(amat, 2) == m, 'SIZE(AMAT) == [N, M]', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + call assert(rhobeg >= rhoend .and. rhoend > 0, 'RHOBEG >= RHOEND > 0', srname) + call assert(all(is_finite(x)), 'X is finite', srname) + call assert(size(xl) == n .and. size(xu) == n, 'SIZE(XL) == N == SIZE(XU)', srname) + call assert(maxfilt >= min(MIN_MAXFILT, maxfun) .and. maxfilt <= maxfun, & + & 'MIN(MIN_MAXFILT, MAXFUN) <= MAXFILT <= MAXFUN', srname) + call assert(maxhist >= 0 .and. maxhist <= maxfun, '0 <= MAXHIST <= MAXFUN', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(maxchist * (maxchist - maxhist) == 0, 'SIZE(CHIST) == 0 or MAXHIST', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! IXL and IXU are the indices of the nontrivial lower and upper bounds, respectively. +call safealloc(ixl, int(count(xl > -BOUNDMAX), IK)) ! Removable in F2003. +call safealloc(ixu, int(count(xu < BOUNDMAX), IK)) ! Removable in F2003. +ixl = trueloc(xl > -BOUNDMAX) +ixu = trueloc(xu < BOUNDMAX) + +! Initialize B, XBASE, XPT, FVAL, CVAL, and KOPT, together with the history, NF, IJ, and EVALUATED. +b = bvec +call initxf(calfun, iprint, maxfun, Aeq, Aineq, amat, beq, bineq, ctol, ftarget, rhobeg, xl, xu, & + & x, b, ij, kopt, nf, chist, cval, fhist, fval, xbase, xhist, xpt, evaluated, subinfo) + +! Report the current best value, and check if user asks for early termination. +terminate = .false. +if (present(callback_fcn)) then + call callback_fcn(xbase + xpt(:, kopt), fval(kopt), nf, 0_IK, cval(kopt), terminate=terminate) + if (terminate) then + subinfo = CALLBACK_TERMINATE + end if +end if + +! Initialize X, F, CONSTR, and CSTRV according to KOPT. +! N.B.: We must set CONSTR and CSTRV. Otherwise, if REDUCE_RHO is TRUE after the very first +! iteration due to SHORTD, then RHOMSG will be called with CONSTR and CSTRV uninitialized. +x = xbase + xpt(:, kopt) +f = fval(kopt) +constr_leq = matprod(Aeq, x) - beq +constr = [xl(ixl) - x(ixl), x(ixu) - xu(ixu), -constr_leq, constr_leq, matprod(Aineq, x) - bineq] +cstrv = maximum([ZERO, constr]) + +! Initialize the filter, including XFILT, FFILT, CONFILT, CFILT, and NFILT. +! N.B.: The filter is used only when selecting which iterate to return. It does not interfere with +! the iterations. LINCOA is NOT a filter method but a trust-region method. All the trust-region +! iterates are supposed to be feasible, but can be infeasible due to rounding errors; the +! geometry-improving iterates are not necessarily feasible. Powell's implementation does not use a +! filter to select the iterate, possibly returning a suboptimal iterate. +nfilt = 0 +do k = 1, npt + if (evaluated(k)) then + call savefilt(cval(k), ctol, cweight, fval(k), xbase + xpt(:, k), nfilt, cfilt, ffilt, xfilt) + end if +end do + +! Finish the initialization if INITXF completed normally and CALLBACK did not request termination; +! otherwise, do not proceed, as XPT etc may be uninitialized, leading to errors or exceptions. +if (subinfo == INFO_DFT) then + ! Initialize [BMAT, ZMAT, IDZ], representing inverse of KKT matrix of the interpolation system. + call inith(ij, xpt, idz, bmat, zmat) + + ! Initialize the quadratic represented by [GOPT, HQ, PQ], so that its gradient at XBASE+XOPT is + ! GOPT; its Hessian is HQ + sum_{K=1}^NPT PQ(K)*XPT(:, K)*XPT(:, K)'. + hq = ZERO + pq = omega_mul(idz, zmat, fval) + gopt = matprod(bmat(:, 1:npt), fval) + hess_mul(xpt(:, kopt), xpt, pq) + pqalt = pq + galt = gopt + if (.not. (all(is_finite(gopt)) .and. all(is_finite(hq)) .and. all(is_finite(pq)))) then + subinfo = NAN_INF_MODEL + end if +end if + +! Check whether to return due to abnormal cases that may occur during the initialization. +if (subinfo /= INFO_DFT) then + info = subinfo + ! Return the best calculated values of the variables. If CTOL > 0, the KOPT decided by SELECTX + ! may not be the same as the one by INITXF. + kopt = selectx(ffilt(1:nfilt), cfilt(1:nfilt), cweight, ctol) + x = xfilt(:, kopt) + f = ffilt(kopt) + constr_leq = matprod(Aeq, x) - beq + constr = [xl(ixl) - x(ixl), x(ixu) - xu(ixu), -constr_leq, constr_leq, matprod(Aineq, x) - bineq] + cstrv = maximum([ZERO, constr]) + call retmsg(solver, info, iprint, nf, f, x, cstrv, constr) + ! Arrange CHIST, FHIST, and XHIST so that they are in the chronological order. + call rangehist(nf, xhist, fhist, chist) + ! Postconditions + if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(size(chist) == maxchist, 'SIZE(CHIST) == MAXCHIST', srname) + call assert(.not. any(chist(1:min(nf, maxchist)) < 0 .or. is_nan(chist(1:min(nf, maxchist))) & + & .or. is_posinf(chist(1:min(nf, maxchist)))), 'CHIST does not contain negative values or NaN/+Inf', srname) + nhist = minval([nf, maxfhist, maxchist]) + call assert(.not. any(isbetter(fhist(1:nhist), chist(1:nhist), f, cstrv, ctol)),& + & 'No point in the history is better than X', srname) + end if + return +end if + +! Initialize RESCON. +rescon = max(b - matprod(xpt(:, kopt), amat), ZERO) +rescon(trueloc(rescon >= rhobeg)) = -rescon(trueloc(rescon >= rhobeg)) +!!MATLAB: rescon(rescon >= rhobeg) = -rescon(rescon >= rhobeg) + +! Set some more initial values. +! We must initialize RATIO. Otherwise, when SHORTD = TRUE, compilers may raise a run-time error that +! RATIO is undefined. But its value will not be used: when SHORTD = FALSE, its value will be +! overwritten; when SHORTD = TRUE, its value is used only in BAD_TRSTEP, which is TRUE regardless of +! RATIO. Similar for KNEW_TR. +! No need to initialize SHORTD unless MAXTR < 1, but some compilers may complain if we do not do it. +rho = rhobeg +delta = rho +ratio = -ONE +dnorm_rec = REALMAX +shortd = .false. +trfail = .false. +qalt_better = .false. +knew_tr = 0 +knew_geo = 0 +qfac = eye(n) +rfac = ZERO +nact = 0 +iact = linspace(1_IK, m, m) + +! If DELTA <= GAMMA3*RHO after an update, we set DELTA to RHO. GAMMA3 must be less than GAMMA2. The +! reason is as follows. Imagine a very successful step with DENORM = the un-updated DELTA = RHO. +! Then TRRAD will update DELTA to GAMMA2*RHO. If GAMMA3 >= GAMMA2, then DELTA will be reset to RHO, +! which is not reasonable as D is very successful. See paragraph two of Sec. 5.2.5 in +! T. M. Ragonneau's thesis: "Model-Based Derivative-Free Optimization Methods and Software". +! According to test on 20230613, for LINCOA, this Powellful updating scheme of DELTA works evidently +! better than setting directly DELTA = MAX(NEW_DELTA, RHO). +gamma3 = max(ONE, min(0.75_RP * gamma2, 1.5_RP)) + +! MAXTR is the maximal number of trust-region iterations. Here, we set it to HUGE(MAXTR) - 1 so that +! the algorithm will not terminate due to MAXTR. However, this may not be allowed in other languages +! such as MATLAB. In that case, we can set MAXTR to 10*MAXFUN, which is unlikely to reach because +! each trust-region iteration takes 1 or 2 function evaluations unless the trust-region step is short +! or fails to reduce the trust-region model but the geometry step is not invoked. +! N.B.: Do NOT set MAXTR to HUGE(MAXTR), as it may cause overflow and infinite cycling in the DO +! loop. See +! https://fortran-lang.discourse.group/t/loop-variable-reaching-integer-huge-causes-infinite-loop +! https://fortran-lang.discourse.group/t/loops-dont-behave-like-they-should +maxtr = huge(maxtr) - 1_IK !!MATLAB: maxtr = 10 * maxfun; +info = MAXTR_REACHED + +! Begin the iterative procedure. +! After solving a trust-region subproblem, we use three boolean variables to control the workflow. +! SHORTD: Is the trust-region trial step too short to invoke a function evaluation? +! IMPROVE_GEO: Should we improve the geometry? +! REDUCE_RHO: Should we reduce rho? +! LINCOA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. +do tr = 1, maxtr + ! Generate the next trust region step D by calling TRSTEP. Note that D is feasible. + call trstep(amat, delta, gopt, hq, pq, rescon, trtol, xpt, iact, nact, qfac, rfac, d, ngetact) + dnorm = min(delta, norm(d)) + + ! A trust region step is applied whenever its length is at least 0.5*DELTA. It is also + ! applied if its length is at least 0.1999*DELTA and if a line search of TRSTEP has caused a + ! change to the active set, indicated by NGETACT >= 2 (note that NGETACT is at least 1). + ! Otherwise, the trust region step is considered too short to try. + ! N.B. The magic number 0.1999 seems to be related to the fact that a linear constraint is + ! considered nearly active if the point under consideration is within 0.2*DELTA to the boundary + ! of the constraint. See the subroutine GETACT and Section 3 of Powell (2015) for more details. + ! `<=` works better than `<` in case of underflow. + shortd = ((dnorm <= HALF * delta .and. ngetact < 2) .or. dnorm <= 0.1999_RP * delta) + !------------------------------------------------------------------------------------------! + ! The SHORTD defined above needs NGETACT, which relies on Powell's trust region subproblem + ! solver. If a different subproblem solver is used, we can take the following SHORTD adopted + ! from UOBYQA, NEWUOA and BOBYQA. + ! !SHORTD = (DNORM < HALF * RHO) + !------------------------------------------------------------------------------------------! + + ! DNORM_REC records the DNORM of recent trust-region iterations. It will be used to decide + ! whether we should improve the geometry of the interpolation set or reduce RHO when SHORTD + ! is TRUE. Note that it does not record the geometry steps. + dnorm_rec = [dnorm_rec(2:size(dnorm_rec)), dnorm] + + ! In some cases, we reset DNORM_REC to REALMAX. This indicates a preference of improving the + ! geometry of the interpolation set to reducing RHO in the subsequent three or more iterations. + ! This is important for the performance of LINCOA. + ! Zaikun 20230609: This does not exist in NEWUOA/BOBYQA/UOBYQA. Try it! + if (delta > rho .or. .not. shortd) then ! Another possibility: IF (DELTA > RHO) THEN + dnorm_rec = REALMAX + end if + + ! Set QRED to the reduction of the quadratic model when the move D is made from XOPT. QRED + ! should be positive. If it is nonpositive due to rounding errors, we will not take this step. + qred = -quadinc(d, xpt, gopt, pq, hq) ! QRED = Q(XOPT) - Q(XOPT + D) + trfail = (.not. qred > 1.0E-6 * rho**2) ! QRED is tiny/negative or NaN. + + if (shortd .or. trfail) then + ! In this case, do nothing but reducing DELTA. Afterward, DELTA < DNORM may occur. + ! N.B.: 1. This value of DELTA will be discarded if REDUCE_RHO turns out TRUE later. + ! 2. Powell's code does not shrink DELTA when TRFAIL is TRUE (i.e., when VQUAD >= 0 in + ! Powell's code, where VQUAD = -QRED). Consequently, the algorithm may be stuck in an + ! infinite cycling, because both REDUCE_RHO and IMPROVE_GEO may end up with FALSE in this + ! case, which did happen in tests. + ! 3. The factor HALF works better than TENTH (used in NEWUOA/BOBYQA), 0.2, and 0.7. + delta = HALF * delta + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + else + ! Calculate the next value of the objective function. + x = xbase + (xpt(:, kopt) + d) + call evaluate(calfun, x, f) + nf = nf + 1_IK + + ! Evaluate the constraints. They are used only for printing messages. + constr_leq = matprod(Aeq, x) - beq + constr = [xl(ixl) - x(ixl), x(ixu) - xu(ixu), -constr_leq, constr_leq, matprod(Aineq, x) - bineq] + cstrv = maximum([ZERO, constr]) + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Trust region', iprint, nf, delta, f, x, cstrv, constr) + ! Save X, F, CSTRV into the history. + call savehist(nf, x, xhist, f, fhist, cstrv, chist) + ! Save X, F, CSTRV into the filter. + call savefilt(cstrv, ctol, cweight, f, x, nfilt, cfilt, ffilt, xfilt) + + ! Check whether to exit. + subinfo = checkexit(maxfun, nf, cstrv, ctol, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + + ! QALT_BETTER is a boolean array indicating whether the recent few (three) alternative + ! models are more accurate in predicting the function value at XOPT + D. + ! N.B.: Do NOT change the "<" in the comparison to "<="; otherwise, the result will not be + ! reasonable if the two values being compared are both ZERO or INF. + moderr = f - fval(kopt) + qred + moderr_alt = f - fval(kopt) - quadinc(d, xpt, galt, pqalt) + qalt_better = [qalt_better(2:size(qalt_better)), abs(moderr_alt) < TENTH * abs(moderr)] + + ! Calculate the reduction ratio by REDRAT, which handles Inf/NaN carefully. + ratio = redrat(fval(kopt) - f, qred, eta1) + + ! Update DELTA. After this, DELTA < DNORM may hold. + ! The new DELTA lies in [GAMMA1*DNORM, GAMMA2*DNORM]. + delta = trrad(delta, dnorm, eta1, eta2, gamma1, gamma2, ratio) + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + + ! Is the newly generated X better than current best point? + ximproved = (f < fval(kopt)) + + ! Set KNEW_TR to the index of the interpolation point to be replaced with XNEW = XOPT + D. + ! KNEW_TR will ensure that the geometry of XPT is "good enough" after the replacement. + knew_tr = setdrop_tr(idz, kopt, ximproved, bmat, d, delta, rho, xpt, zmat) + if (knew_tr > 0) then + ! Update [BMAT, ZMAT, IDZ] (represents H in the NEWUOA paper), [XPT, FVAL, KOPT] and + ! [GOPT, HQ, PQ] (the quadratic model), so that XPT(:, KNEW_TR) becomes XNEW = XOPT + D. + xdrop = xpt(:, knew_tr) + xosav = xpt(:, kopt) + call updateh(knew_tr, kopt, d, xpt, idz, bmat, zmat) + call updatexf(knew_tr, ximproved, f, xosav + d, kopt, fval, xpt) + call updateq(idz, knew_tr, ximproved, bmat, d, moderr, xdrop, xosav, xpt, zmat, gopt, hq, pq) + + ! Establish the alternative model, namely the least Frobenius norm interpolant. Replace + ! the current model with the alternative model if the recent few (three) alternative + ! models are more accurate in predicting the function value of XOPT + D. + call tryqalt(idz, bmat, fval - fval(kopt), xpt(:, kopt), xpt, zmat, qalt_better, gopt, pq, hq, galt, pqalt) + if (.not. (all(is_finite(gopt)) .and. all(is_finite(hq)) .and. all(is_finite(pq)))) then + info = NAN_INF_MODEL + exit + end if + + ! Update RESCON if XOPT is changed. + ! Zaikun 20221115: Shouldn't we do it after DELTA is updated? + call updateres(ximproved, amat, b, delta, norm(d), xpt(:, kopt), rescon) + end if + + end if ! End of IF (SHORTD .OR. TRFAIL). The normal trust-region calculation ends. + + !----------------------------------------------------------------------------------------------! + ! Before the next trust-region iteration, we may improve the geometry of XPT or reduce RHO + ! according to IMPROVE_GEO and REDUCE_RHO, which in turn depend on the following indicators. + ! N.B.: We must ensure that the algorithm does not set IMPROVE_GEO = TRUE at infinitely many + ! consecutive iterations without moving XOPT or reducing RHO. Otherwise, the algorithm will get + ! stuck in repetitive invocations of GEOSTEP. To this end, make sure the following. + ! 1. The threshold for CLOSE_ITPSET is at least DELBAR, the trust region radius for GEOSTEP. + ! Normally, DELBAR <= DELTA <= the threshold (In Powell's UOBYQA, DELBAR = RHO < the threshold). + ! 2. If an iteration sets IMPROVE_GEO = TRUE, it must also reduce DELTA or set DELTA to RHO. + + ! ACCURATE_MOD: Are the recent models sufficiently accurate? Used only if SHORTD is TRUE. + ! N.B.: The ACCURATE_MOD here plays a similar role as the variable with the same name in UOBYQA, + ! NEWUOA, and BOBYQA. However, the definition of ACCURATE_MOD here is different from that in + ! those solvers, which do not only check whether DNORM is small in recent iterations, but also + ! verify a curvature condition that really indicates that recent models are sufficiently + ! accurate. Here, however, we are not really sure whether they are accurate or not. Therefore, + ! ACCURATE_MOD is not the best name, but we keep it to align with the other solvers. + accurate_mod = all(dnorm_rec <= rho) .or. all(dnorm_rec(2:size(dnorm_rec)) <= 0.2 * rho) + ! Powell's version (note that size(dnorm_rec) = 5 in his implementation): + !accurate_mod = all(dnorm_rec <= HALF * rho) .or. all(dnorm_rec(3:size(dnorm_rec)) <= TENTH * rho) + ! CLOSE_ITPSET: Are the interpolation points close to XOPT? + distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - xpt(:, kopt)).^2) % Implicit expansion + close_itpset = all(distsq <= 4.0_RP * delta**2) ! Powell's NEWUOA code. + ! Below are some alternative definitions of CLOSE_ITPSET. + ! N.B.: The threshold for CLOSE_ITPSET is at least DELBAR, the trust region radius for GEOSTEP. + ! !close_itpset = all(distsq <= 4.0_RP * rho**2) ! Powell's UOBYQA code. + ! !close_itpset = all(distsq <= max(delta**2, 4.0_RP * rho**2)) ! Powell's code. + ! !close_itpset = all(distsq <= max((TWO * delta)**2, (TEN * rho)**2)) ! Powell's BOBYQA code. + ! ADEQUATE_GEO: Is the geometry of the interpolation set "adequate"? + adequate_geo = (shortd .and. accurate_mod) .or. close_itpset + ! SMALL_TRRAD: Is the trust-region radius small? This indicator seems not impactive in practice. + small_trrad = (max(delta, dnorm) <= rho) ! Behaves the same as Powell's version. + !small_trrad = (delsav <= rho) ! Powell's code. DELSAV = unupdated DELTA. + + ! IMPROVE_GEO and REDUCE_RHO are defined as follows. + ! N.B.: If SHORTD is TRUE at the very first iteration, then REDUCE_RHO will be set to TRUE. + + ! BAD_TRSTEP (for IMPROVE_GEO): Is the last trust-region step bad? + bad_trstep = (shortd .or. trfail .or. ratio <= eta1 .or. knew_tr == 0) + improve_geo = bad_trstep .and. .not. adequate_geo + ! BAD_TRSTEP (for REDUCE_RHO): Is the last trust-region step bad? + bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) + reduce_rho = bad_trstep .and. adequate_geo .and. small_trrad + + ! Equivalently, REDUCE_RHO can be set as follows. It shows that REDUCE_RHO is TRUE in two cases. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) + ! !reduce_rho = (shortd .and. accurate_mod) .or. (bad_trstep .and. close_itpset .and. small_trrad) + + ! With REDUCE_RHO properly defined, we can also set IMPROVE_GEO as follows. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= eta1 .or. knew_tr == 0) + ! !improve_geo = bad_trstep .and. (.not. reduce_rho) .and. (.not. close_itpset) + + ! With IMPROVE_GEO properly defined, we can also set REDUCE_RHO as follows. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) + ! !reduce_rho = bad_trstep .and. (.not. improve_geo) .and. small_trrad + + ! LINCOA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. + !call assert(.not. (improve_geo .and. reduce_rho), 'IMPROVE_GEO and REDUCE_RHO are not both TRUE', srname) + ! + ! If SHORTD or TRFAIL is TRUE, then either IMPROVE_GEO or REDUCE_RHO is TRUE unless CLOSE_ITPSET + ! is TRUE but SMALL_TRRAD is FALSE. + !call assert((.not. (shortd .or. trfail)) .or. (improve_geo .or. reduce_rho .or. & + ! & (close_itpset .and. .not. small_trrad)), 'If SHORTD or TRFAIL is TRUE, then either & + ! & IMPROVE_GEO or REDUCE_RHO is TRUE unless CLOSE_ITPSET is TRUE but SMALL_TRRAD is FALSE', srname) + !----------------------------------------------------------------------------------------------! + + + ! Since IMPROVE_GEO and REDUCE_RHO are never TRUE simultaneously, the following two blocks are + ! exchangeable: IF (IMPROVE_GEO) ... END IF and IF (REDUCE_RHO) ... END IF. + + if (improve_geo) then + ! XPT(:, KNEW_GEO) will become XOPT + D below. KNEW_GEO /= KOPT unless there is a bug. + knew_geo = int(maxloc(distsq, dim=1), kind(knew_geo)) + + ! Set DELBAR, which will be used as the trust-region radius for the geometry-improving + ! scheme GEOSTEP. Note that DELTA has been updated before arriving here. + delbar = max(TENTH * delta, rho) ! Powell's code + !delbar = rho ! Powell's UOBYQA code + !delbar = max(min(TENTH * sqrt(maxval(distsq)), HALF * delta), rho) ! Powell's NEWUOA code + !delbar = max(min(TENTH * sqrt(maxval(distsq)), delta), rho) ! Powell's BOBYQA code + ! Find D so that the geometry of XPT will be improved when XPT(:, KNEW_GEO) becomes XOPT + D. + call geostep(iact, idz, knew_geo, kopt, nact, amat, bmat, delbar, qfac, rescon, xpt, zmat, feasible, d) + + ! Calculate the next value of the objective function. + x = xbase + (xpt(:, kopt) + d) + call evaluate(calfun, x, f) + nf = nf + 1_IK + + ! Evaluate the constraints. They are used only for printing messages. + constr_leq = matprod(Aeq, x) - beq + constr = [xl(ixl) - x(ixl), x(ixu) - xu(ixu), -constr_leq, constr_leq, matprod(Aineq, x) - bineq] + cstrv = maximum([ZERO, constr]) + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Geometry', iprint, nf, delbar, f, x, cstrv, constr) + ! Save X, F, CSTRV into the history. + call savehist(nf, x, xhist, f, fhist, cstrv, chist) + ! Save X, F, CSTRV into the filter. + call savefilt(cstrv, ctol, cweight, f, x, nfilt, cfilt, ffilt, xfilt) + + ! Check whether to exit. + subinfo = checkexit(maxfun, nf, cstrv, ctol, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + + ! QALT_BETTER is a boolean array indicating whether the recent few (three) alternative + ! models are more accurate in predicting the function value at XOPT + D. + ! Powell's code takes XOPT + D into account only if it is feasible. + ! N.B.: Do NOT change the "<" in the comparison to "<="; otherwise, the result will not be + ! reasonable if the two values being compared are both ZERO or INF. + moderr = f - fval(kopt) - quadinc(d, xpt, gopt, pq, hq) + moderr_alt = f - fval(kopt) - quadinc(d, xpt, galt, pqalt) + qalt_better = [qalt_better(2:size(qalt_better)), abs(moderr_alt) < TENTH * abs(moderr)] + + ! Is the newly generated X better than current best point? + ximproved = (f < fval(kopt) .and. feasible) + + ! Update [BMAT, ZMAT, IDZ] (represents H in the NEWUOA paper), [XPT, FVAL, KOPT] and + ! [GOPT, HQ, PQ] (the quadratic model), so that XPT(:, KNEW_GEO) becomes XNEW = XOPT + D. + xdrop = xpt(:, knew_geo) + xosav = xpt(:, kopt) + call updateh(knew_geo, kopt, d, xpt, idz, bmat, zmat) + call updatexf(knew_geo, ximproved, f, xosav + d, kopt, fval, xpt) + call updateq(idz, knew_geo, ximproved, bmat, d, moderr, xdrop, xosav, xpt, zmat, gopt, hq, pq) + + ! Establish the alternative model, namely the least Frobenius norm interpolant. Replace the + ! current model with the alternative model if the recent few (three) alternative models are + ! more accurate in predicting the function value of XOPT + D. + ! N.B.: Powell's code does this only if XOPT + D is feasible. + call tryqalt(idz, bmat, fval - fval(kopt), xpt(:, kopt), xpt, zmat, qalt_better, gopt, pq, hq, galt, pqalt) + if (.not. (all(is_finite(gopt)) .and. all(is_finite(hq)) .and. all(is_finite(pq)))) then + info = NAN_INF_MODEL + exit + end if + + ! Update RESCON. Zaikun 20221115: Currently, UPDATERES does not update RESCON if XIMPROVED + ! is FALSE. Shouldn't we do it whenever DELTA is updated? Have we MISUNDERSTOOD RESCON? + call updateres(ximproved, amat, b, delta, norm(d), xpt(:, kopt), rescon) + end if ! End of IF (IMPROVE_GEO). The procedure of improving geometry ends. + + ! The calculations with the current RHO are complete. Enhance the resolution of the algorithm + ! by reducing RHO; update DELTA at the same time. + if (reduce_rho) then + if (rho <= rhoend) then + info = SMALL_TR_RADIUS + exit + end if + delta = max(HALF * rho, redrho(rho, rhoend)) + rho = redrho(rho, rhoend) + ! Print a message about the reduction of RHO according to IPRINT. + call rhomsg(solver, iprint, nf, delta, fval(kopt), rho, xbase + xpt(:, kopt), cstrv, constr) + ! DNORM_REC is corresponding to the latest function evaluations with the current RHO. + ! Update it after reducing RHO. + dnorm_rec = REALMAX + end if ! End of IF (REDUCE_RHO). The procedure of reducing RHO ends. + + ! Shift XBASE if XOPT may be too far from XBASE. + ! Powell's original criterion for shifting XBASE: before a trust region step or a geometry step, + ! shift XBASE if SUM(XOPT**2) >= 1.0E3*DELTA**2. + if (sum(xpt(:, kopt)**2) >= 1.0E3_RP * delta**2) then + ! Other possible criteria: SUM(XOPT**2) >= 1.0E4*DELTA**2, SUM(XOPT**2) >= 1.0E3*RHO**2. + b = b - matprod(xpt(:, kopt), amat) + call shiftbase(kopt, xbase, xpt, zmat, bmat, pq, hq, idz) + ! SHIFTBASE shifts XBASE to XBASE + XOPT and XOPT to 0. + pqalt = omega_mul(idz, zmat, fval - fval(kopt)) + galt = matprod(bmat(:, 1:npt), fval - fval(kopt)) + hess_mul(xpt(:, kopt), xpt, pqalt) + end if + + ! Report the current best value, and check if user asks for early termination. + if (present(callback_fcn)) then + ! FIXME: CVAL(KOP) is WRONG! CVAL is not updated. + call callback_fcn(xbase + xpt(:, kopt), fval(kopt), nf, tr, cval(kopt), terminate=terminate) + if (terminate) then + info = CALLBACK_TERMINATE + exit + end if + end if + +end do ! End of DO TR = 1, MAXTR. The iterative procedure ends. + +! Return from the calculation, after trying the Newton-Raphson step if it has not been tried yet. +if (info == SMALL_TR_RADIUS .and. shortd .and. dnorm > TENTH * rhoend .and. nf < maxfun) then + x = xbase + (xpt(:, kopt) + d) + call evaluate(calfun, x, f) + nf = nf + 1_IK + constr_leq = matprod(Aeq, x) - beq + constr = [xl(ixl) - x(ixl), x(ixu) - xu(ixu), -constr_leq, constr_leq, matprod(Aineq, x) - bineq] + cstrv = maximum([ZERO, constr]) + ! Print a message about the function evaluation according to IPRINT. + ! Zaikun 20230512: DELTA has been updated. RHO is only indicative here. TO BE IMPROVED. + call fmsg(solver, 'Trust region', iprint, nf, rho, f, x, cstrv, constr) + ! Save X, F, CSTRV into the history. + call savehist(nf, x, xhist, f, fhist, cstrv, chist) + ! Save X, F, CSTRV into the filter. + call savefilt(cstrv, ctol, cweight, f, x, nfilt, cfilt, ffilt, xfilt) +end if + +! Return the best calculated values of the variables. +kopt = selectx(ffilt(1:nfilt), cfilt(1:nfilt), cweight, ctol) +x = xfilt(:, kopt) +f = ffilt(kopt) +constr_leq = matprod(Aeq, x) - beq +constr = [xl(ixl) - x(ixl), x(ixu) - xu(ixu), -constr_leq, constr_leq, matprod(Aineq, x) - bineq] +cstrv = maximum([ZERO, constr]) + +! Deallocate IXL and IXU as they have finished their job. +deallocate (ixl, ixu) + +! Arrange CHIST, FHIST, and XHIST so that they are in the chronological order. +call rangehist(nf, xhist, fhist, chist) + +! Print a return message according to IPRINT. +call retmsg(solver, info, iprint, nf, f, x, cstrv, constr) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(size(chist) == maxchist, 'SIZE(CHIST) == MAXCHIST', srname) + call assert(.not. any(chist(1:min(nf, maxchist)) < 0 .or. is_nan(chist(1:min(nf, maxchist))) & + & .or. is_posinf(chist(1:min(nf, maxchist)))), 'CHIST does not contain negative values or NaN/+Inf', srname) + nhist = minval([nf, maxfhist, maxchist]) + call assert(.not. any(isbetter(fhist(1:nhist), chist(1:nhist), f, cstrv, ctol)),& + & 'No point in the history is better than X', srname) +end if + +end subroutine lincob + + +end module lincob_mod diff --git a/examples/fortran/prima/native/lincoa/trustregion.f90 b/examples/fortran/prima/native/lincoa/trustregion.f90 new file mode 100644 index 000000000..3039fcb3f --- /dev/null +++ b/examples/fortran/prima/native/lincoa/trustregion.f90 @@ -0,0 +1,601 @@ +module trustregion_lincoa_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning the trust-region calculations of LINCOA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the paper +! +! M. J. D. Powell, On fast trust region methods for quadratic models with linear constraints, +! Math. Program. Comput., 7:237--267, 2015 +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Saturday, March 09, 2024 PM12:09:39 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: trstep, trrad + + +contains + + +subroutine trstep(amat, delta, gopt_in, hq_in, pq_in, rescon, tol, xpt, iact, nact, qfac, rfac, s, ngetact) +!--------------------------------------------------------------------------------------------------! +! This subroutine solves +! minimize Q(XOPT + D) s.t. ||D|| <= DELTA, AMAT^T*D <= B. +! It is assumed that D = 0 is feasible, namely B >= 0 except for rounding errors. See Powell 2015 +! for details. +! +! AMAT, B, XPT, GOPT, HQ, PQ, NACT, IACT, RESCON, QFAC and RFAC are the same as the terms with these +! names in LINCOB. +! +! S is the total calculated step so far from the trust region centre, its final value being given by +! the sequence of CG iterations, which terminate if the trust region boundary is reached. +! G is always the gradient of the model at the current S. +! D is the search direction of each line search. +! RESCON: If RESCON(J) is negative, then |RESCON(J)| must be no less than the trust region radius, +! so that the J-th constraint can be ignored. +! RESNEW: A negative value of RESNEW(J) indicates that the J-th constraint does not restrict the CG +! steps of the current trust region calculation, a zero value of RESNEW(J) indicates that the J-th +! constraint is active, and otherwise RESNEW(J) is set to the greater of TINYCV and the actual +! residual of the J-th constraint for the current S. +! RESACT holds the residuals of the active constraints, which may be positive. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, ZERO, TWO, HALF, TEN, MAXPOW10, EPS, REALMIN, TINYCV, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan +use, non_intrinsic :: linalg_mod, only : matprod, inprod, norm, solve, isorth, istriu, & + & issymmetric, trueloc +use, non_intrinsic :: powalg_mod, only : hess_mul + +! Solver-specific modules +use, non_intrinsic :: getact_mod, only : getact + +implicit none + +! Inputs +real(RP), intent(in) :: amat(:, :) ! AMAT(N, M) +real(RP), intent(in) :: delta +real(RP), intent(in) :: gopt_in(:) ! GOPT_IN(N) +real(RP), intent(in) :: hq_in(:, :) ! HQ_IN(N, N) +real(RP), intent(in) :: pq_in(:) ! PQ_IN(NPT) +real(RP), intent(in) :: rescon(:) ! RESCON(M) +real(RP), intent(in) :: tol +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! In-outputs +integer(IK), intent(inout) :: iact(:) ! IACT(M); Will be updated in GETACT +integer(IK), intent(inout) :: nact ! Will be updated in GETACT +real(RP), intent(inout) :: qfac(:, :) ! QFAC(N, N); Will be updated in GETACT +real(RP), intent(inout) :: rfac(:, :) ! RFAC(N, N); Will be updated in GETACT + +! Outputs +real(RP), intent(out) :: s(:) ! S(N) +integer(IK), intent(out), optional :: ngetact + +! Local variables +character(len=*), parameter :: srname = 'TRSTEP' +integer(IK) :: iter +integer(IK) :: itercg +integer(IK) :: jsav +integer(IK) :: m +integer(IK) :: maxiter +integer(IK) :: n +integer(IK) :: ngetact_loc +integer(IK) :: npt +logical :: newact +real(RP) :: ad(size(amat, 2)) +real(RP) :: alpha +real(RP) :: alphm +real(RP) :: alpht +real(RP) :: beta +real(RP) :: d(size(gopt_in)) +real(RP) :: dd +real(RP) :: delsq +real(RP) :: dg +real(RP) :: dhd +real(RP) :: dproj(size(gopt_in)) +real(RP) :: ds +real(RP) :: frac(size(amat, 2)) +real(RP) :: g(size(gopt_in)) +real(RP) :: gamma +real(RP) :: gopt(size(gopt_in)) +real(RP) :: hd(size(gopt_in)) +real(RP) :: hq(size(hq_in, 1), size(hq_in, 2)) +real(RP) :: modscal +real(RP) :: orthtol +real(RP) :: pg(size(gopt_in)) +real(RP) :: pq(size(pq_in)) +real(RP) :: psd(size(gopt_in)) +real(RP) :: reduct +real(RP) :: resact(size(amat, 2)) +real(RP) :: resid +real(RP) :: resnew(size(amat, 2)) +real(RP) :: restmp(size(amat, 2)) +real(RP) :: sold(size(s)) +real(RP) :: sqrtd +real(RP) :: ss + +! Sizes. +m = int(size(amat, 2), kind(m)) +n = int(size(gopt_in), kind(n)) +npt = int(size(pq_in), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(m >= 0, 'M >= 0', srname) + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(delta > 0, 'DELTA > 0', srname) + call assert(size(amat, 1) == n .and. size(amat, 2) == m, 'SIZE(AMAT) == [N, M]', srname) + call assert(size(hq_in, 1) == n .and. issymmetric(hq_in), 'HQ is n-by-n and symmetric', srname) + call assert(size(rescon) == m, 'SIZE(RESCON) == M', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(nact >= 0 .and. nact <= min(m, n), '0 <= NACT <= MIN(M, N)', srname) + call assert(size(iact) == m, 'SIZE(IACT) == M', srname) + call assert(all(iact(1:nact) >= 1 .and. iact(1:nact) <= m), '1 <= IACT <= M', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + orthtol = max(TEN**max(-10, -MAXPOW10), min(1.0E-1_RP, TEN**min(8, MAXPOW10) * EPS * real(n, RP))) + call assert(isorth(qfac, orthtol), 'QFAC is orthogonal', srname) + call assert(size(rfac, 1) == n .and. size(rfac, 2) == n, 'SIZE(RFAC) == [N, N]', srname) + call assert(istriu(rfac), 'RFAC is upper triangular', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Scale the problem if GOPT contains large values. Otherwise, floating point exceptions may occur. +! Note that the trust-region step is scale invariant. +! N.B.: It is faster and safer to scale by multiplying a reciprocal than by division. See +! https://fortran-lang.discourse.group/t/ifort-ifort-2021-8-0-1-0e-37-1-0e-38-0/ +if (maxval(abs(gopt_in)) > 1.0E12) then ! The threshold is empirical. + modscal = max(TWO * REALMIN, ONE / maxval(abs(gopt_in))) ! MAX: precaution against underflow. + gopt = gopt_in * modscal + pq = pq_in * modscal + hq = hq_in * modscal +else + gopt = gopt_in + pq = pq_in + hq = hq_in +end if + +! Return if G is not finite. Otherwise, GETACT will fail in the debugging mode. +if (.not. is_finite(sum(abs(gopt)))) then + s = ZERO + if (present(ngetact)) then + ngetact = 0 + end if + return +end if + +! Set the initial elements of RESNEW, RESACT and S. + +! 1. RESNEW(J) < 0 indicates that the J-th constraint does not restrict the CG steps of the current +! trust region calculation. In other words, RESCON >= DELTA. +! 2. RESNEW(J) = 0 indicates that J is an entry of IACT(1:NACT). +! 3. RESNEW(J) > 0 means that RESNEW(J) = max(B(J) - AMAT(:, J)^T*(XOPT+S), TINYCV), where S is the +! step up to now, calculated by a sequence of (truncated) CG iterations. +! N.B.: The order of the following lines is important, as the later ones override the earlier. +resnew = rescon +resnew(trueloc(rescon >= 0)) = max(TINYCV, rescon(trueloc(rescon >= 0))) +resnew(trueloc(rescon >= delta)) = -ONE +!!MATLAB: +!!resnew = rescon; resnew(rescon >= 0) = max(TINYCV, rescon(rescon >= 0)); resnew(rescon >= delta) = -1; +resnew(iact(1:nact)) = ZERO + +! RESACT contains the constraint residuals of the constraints in IACT(1:NACT), namely the values +! of B(J) - AMAT(:, J)^T*(XOPT+S) for the J in IACT(1:NACT). Here, IACT(1:NACT) is a set of +! indicates such that the columns of AMAT(:, IACT(1:NACT)) form a basis of the constraint gradients +! in the "active set". For the definition of the "active set", see (3.5) of Powell (2015) and the +! comments at the beginning of the GETACT subroutine. +! N.B.: Between two calls of GETACT, S is updated in the orthogonal complement of the "active" +! gradients (i.e., null space of the "active" constraints). Therefore, RESACT remains unchanged. +! RESACT is changed right after GETACT is called if the first search direction D is not PSD +! but PSD + GAMMA * DPROJ. +resact(1:nact) = rescon(iact(1:nact)) + +g = gopt +delsq = delta * delta +s = ZERO +ss = ZERO +reduct = ZERO +ngetact_loc = 0 +newact = .true. + +! ITERCG is the number of CG iterations corresponding to the current "active set" obtained by +! calling GETACT. These CG iterations are restricted in the orthogonal complement of the active +! gradients (i.e., null space of the active constraints). +! The following initial value of ITERCG is an artificial value that is not used. It is to entertain +! Fortran compilers (can it be be removed?). +itercg = -1 + +! What is the THEORETICAL upper bound of ITER? For the moment, we set the following MAXITER. +! The formulation of MAXITER below contains a precaution against overflow. In MATLAB/Python/Julia/R, +! we can write maxiter = min(10000, 10*(m + n)) +maxiter = int(min(10**min(4, range(0_IK)), 10 * int(m + n)), IK) +do iter = 1, maxiter ! Powell's code is essentially a DO WHILE loop. We impose an explicit MAXITER. + if (newact) then + ! GETACT picks the active set for the current S. It also sets PSD to the vector closest to + ! -G that is orthogonal to the normals of the active constraints. PSD is scaled to have + ! length 0.2*DELTA. Then a move of PSD from S is allowed by the linear constraints: PSD + ! reduces the values of the nearly active constraints; it changes the inactive constraints + ! by at most 0.2*DELTA, but the residuals of these constraints at no less than 0.2*DELTA. + ! N.B.: The magic number 0.2 appears also in GETACT (TDEL = 0.2_RP * DELTA). It works well. + ngetact_loc = ngetact_loc + 1_IK + call getact(amat, delta, g, iact, nact, qfac, resact, resnew, rfac, psd) + dd = inprod(psd, psd) + if (dd <= EPS * delsq .or. is_nan(dd)) then ! Powell's code: IF (DD <= 0) THEN + exit + end if + psd = (0.2_RP * delta / sqrt(dd)) * psd + + ! If the modulus of the residual of an "active constraint" is substantial (i.e., more than + ! 1.0E-4*DELTA), then modify the searching direction PSD by a projection step to the + ! boundaries of the "active constraint". This modified step will reduce the constraint + ! residuals of the "active constraints" (see the update of RESACT below). The motivation is + ! that the constraints in the "active set" are presumed to be active, and hence should have + ! zero residuals (no constraint is violated, as the current method is feasible). According + ! to a test on 20220821, this modification is important for the performance of LINCOA. + ! N.B.: + ! 1. The residual of the constraint A*X <= B is defined as B - A*X. It is not the constraint + ! violation. Indeed, the constraint violations of the iterates are 0 in the current method. + ! 2. We prefer `ANY(X > Y)` to `MAXVAL(X) > Y`, as Fortran standards do not specify + ! MAXVAL(X) when X contains NaN, and MATLAB/Python/R/Julia behave differently in this + ! respect. Moreover, MATLAB defines max(X) = [] if X == [], differing from mathematics + ! and other languages. + gamma = ZERO ! The steplength of the projection step to be taken. + if (any(resact(1:nact) > 1.0E-4_RP * delta)) then + ! Set DPROJ to the shortest move (projection step) from S to the boundaries of the + ! active constraints. We will use DPROJ to modify PSD. + dproj = matprod(qfac(:, 1:nact), solve(transpose(rfac(1:nact, 1:nact)), resact(1:nact))) + !!MATLAB: dproj = qfac(:, 1:nact) * (rfac(1:nact, 1:nact)' \ resact(1:nact)) + + ! The vector DPROJ is also the shortest move from S + PSD to the boundaries of the + ! active constraints (this is because PSD is parallel to the boundaries of the active + ! constraints). Set GAMMA to the greatest steplength of this move that satisfies both + ! the trust region bound and the linear constraints. + ds = inprod(dproj, s + psd) + dd = sum(dproj**2) + resid = delsq - sum((s + psd)**2) + ! Powell's condition for the following IF: RESID > 0. + if (resid > 0 .and. dd > EPS * delsq .and. .not. is_nan(ds)) then + ! Set GAMMA to the greatest value so that S + PSD + GAMMA*DPROJ satisfies the trust + ! region bound. SQRTD: square root of a discriminant. Powell's code for SQRTD is + ! SQRT(DS * DS + DD * RESID), which may be below ABS(DS) due to underflow in DS*DS. + sqrtd = maxval([sqrt(ds * ds + dd * resid), abs(ds), sqrt(dd * resid)]) + if (ds <= 0) then + gamma = (sqrtd - ds) / dd + else + gamma = resid / (sqrtd + ds) + end if + ! GAMMA < 0 should not happen. GAMMA can be 0 or NaN when, e.g., DS or DD becomes + ! Inf. Powell's code does not handle this. + if (gamma < 0 .or. .not. is_finite(gamma)) then + gamma = 0 + end if + + ! Reduce GAMMA so that the move along DPROJ also satisfies the linear constraints. + ad = -ONE + ad(trueloc(resnew > 0)) = matprod(dproj, amat(:, trueloc(resnew > 0))) + frac = ONE + restmp(trueloc(ad > 0)) = resnew(trueloc(ad > 0)) - matprod(psd, amat(:, trueloc(ad > 0))) + frac(trueloc(ad > 0)) = restmp(trueloc(ad > 0)) / ad(trueloc(ad > 0)) + gamma = minval([gamma, ONE, frac]) ! GAMMA = MINVAL([GAMMA, ONE, FRAC(TRUELOC(AD>0))]) + end if + end if + + ! Set the next direction for seeking a reduction in the model function subject to the trust + ! region bound and the linear constraints. + ! Do NOT write D = PSD + GAMMA*DPROJ, as DPROJ may contain NaN/Inf, in which case GAMMA = 0. + if (gamma > 0) then + d = psd + gamma * dproj ! Modified searching direction. + itercg = -1 + else + d = psd ! Original searching direction. + itercg = 0 + end if + end if + itercg = itercg + 1_IK + ! After the above line, ITERCG = 0 iff GETACT has been just called, and D is not PSD but a + ! modified step. + + ! Set ALPHA to the steplength from S along D to the trust region boundary. Return if the first + ! derivative term of this step is sufficiently small or if no further progress is possible. + resid = delsq - ss + dg = inprod(d, g) + ds = inprod(d, s) + dd = inprod(d, d) + ! Powell's condition for the following IF: (RESID <= 0 .OR. DG >= 0). If DD is tiny (so is DS), + ! ALPHA may be mistakenly calculated as a huge value due to rounding errors, as observed on + ! 20221205. Therefore, we exit when DD is small. The test for DG is covered by the IF after the + ! calculation of ALPHA. + if (resid <= 0 .or. dd <= EPS * delsq .or. is_nan(ds)) then + exit + end if + ! SQRTD: square root of a discriminant. Powell's code for SQRTD is SQRT(DS * DS + DD * RESID), + ! which may be below ABS(DS) due to underflow in DS*DS. + sqrtd = maxval([sqrt(ds * ds + dd * resid), abs(ds), sqrt(dd * resid)]) + if (ds <= 0) then + alpha = (sqrtd - ds) / dd + else + alpha = resid / (sqrtd + ds) + end if + ! ALPHA < 0 should not happen. ALPHA can be 0 or NaN when, e.g., DS or DD becomes Inf. Powell's + ! code does not handle this. + if (alpha <= 0 .or. .not. is_finite(alpha)) then + exit + end if + + ! Powell's condition for the following IF: -ALPHA * DG <= TOL * REDUCT. Note that the EXIT + ! will be triggered if DG >= 0, as ALPHA >= 0. + if (-alpha * dg <= tol * reduct .or. is_nan(alpha * dg)) then + exit + end if + + ! Set DHD to the curvature of the model along D. Then reduce ALPHA if necessary to the value + ! that minimizes the model. + hd = hess_mul(d, xpt, pq, hq) + dhd = inprod(d, hd) + alpht = alpha + if (dg + alpha * dhd > 0) then + alpha = -dg / dhd + end if + + ! Make a further reduction in ALPHA if necessary to preserve feasibility. + alphm = alpha + ad = -ONE + ad(trueloc(resnew > 0)) = matprod(d, amat(:, trueloc(resnew > 0))) + frac = alpha + frac(trueloc(ad > 0)) = resnew(trueloc(ad > 0)) / ad(trueloc(ad > 0)) + frac(trueloc(is_nan(frac))) = alpha + jsav = 0 + if (any(frac < alpha)) then + jsav = int(minloc(frac, dim=1), kind(jsav)) + alpha = frac(jsav) + end if + !----------------------------------------------------------------------------------------------! + ! Alternatively, JSAV and ALPHA can be calculated as below. + ! !JSAV = INT(MINLOC([ALPHA, FRAC], DIM=1), KIND(JSAV)) - 1_IK + ! !ALPHA = MINVAL([ALPHA, FRAC]) ! This line cannot be exchanged with the last. + ! We prefer our implementation as the code is more explicit; in addition, it is more flexible: + ! we can change the condition ANY(FRAC < ALPHA) to ANY(FRAC < (1 - EPS) * ALPHA) or + ! ANY(FRAC < (1 + EPS) * ALPHA), depending on whether we believe a false positive or a false + ! negative of JSAV > 0 is more harmful. + !----------------------------------------------------------------------------------------------! + + ! Post-process ALPHA according to some prior information. + ! N.B.: + ! 1. Since we set ALPHA=1 when ITERCG=0, the ALPHA calculated above is needed only if ITERCG>0. + ! 2. Zaikun 20220821: In theory, shouldn't this post-processing change nothing? According to + ! a test on 20220821, it does change ALPHA sometimes. Strange! Why? + if (itercg == 0) then ! Iff GETACT has been called, and D is not PSD but a modified step. + ! By the definition of D, ALPHA = ONE is the largest ALPHA so that S + ALPHA*D satisfies the + ! linear and trust region constraints. + alpha = ONE + elseif (itercg == 1 .and. gamma <= 0) then ! Iff GETACT has been called, and D is not modified. + ! Due to the scaling of PSD, S + D satisfies the linear and trust region constraints. + alpha = max(alpha, ONE) + else + alpha = max(alpha, ZERO) + end if + + ! Set ALPHA to the minimum between ALPHA and ALPHM, namely the steplength obtained by minimizing + ! the quadratic model along D. + alpha = min(alpha, alphm) + + ! Update S, G. + sold = s + s = s + alpha * d + ss = sum(s**2) + if (.not. is_finite(ss)) then + s = sold + exit + end if + g = g + alpha * hd + if (.not. is_finite(sum(abs(g)))) then + exit + end if + + ! Update RESNEW. + restmp = resnew - alpha * ad ! Only RESTMP(TRUELOC(RESNEW > 0)) is needed. + resnew(trueloc(resnew > 0)) = max(TINYCV, restmp(trueloc(resnew > 0))) + !!MATLAB: mask = (resnew > 0); resnew(mask) = max(TINYCV, resnew(mask) - alpha * ad(mask)); + + ! Update RESACT. This is done iff GETACT has been called, and D is not PSD but a modified step. + !----------------------------------------------------------------------------------------------! + ! Zaikun 20220821: There seems be a typo here. Powell's original code does not take ALPHA into + ! account. Then RESACT seems to correspond to S + D, where D is defined as PSD + GAMMA*DPROJ + ! during the modification procedure after GETACT is called. Without this modification, RESACT + ! would remain unchanged because D = PSD, which is in the null space of the active constraints. + ! The GAMMA*DPROJ component in the modified step D reduces RESACT by GAMMA*RESACT. However, + ! since S is updated to S + ALPHA*D, shouldn't RESACT be reduced by ALPHA*GAMMA*RESACT? + ! Note that Powell chose to update RESACT after ALPHA is calculated (instead of right after + ! GAMMA is calculated), which might be an indication that he wanted to take ALPHA into account. + ! In the following code, we try correcting this apparent typo, but it has little impact on the + ! performance of LINCOA according to a test on 20220821. + if (itercg == 0) then + resact(1:nact) = (ONE - alpha * gamma) * resact(1:nact) + !resact(1:nact) = (ONE - gamma) * resact(1:nact) ! Powell's code. + end if + !----------------------------------------------------------------------------------------------! + + ! Update REDUCT, the reduction up to now. + reduct = reduct - alpha * (dg + HALF * alpha * dhd) + if (reduct <= 0 .or. is_nan(reduct)) then + s = sold + exit + end if + + ! Test for termination. + if (alpha >= alpht .or. -alphm * (dg + HALF * alphm * dhd) <= tol * reduct) then + exit + end if + + ! Branch to a new loop if there is a new active constraint. + ! When JSAV > 0, Powell's code branches back with NEWACT = .TRUE. only if ||S|| <= 0.8*DELTA, + ! and it exits if ||S|| > 0.8*DELTA, as mentioned at the end of Section 3 of Powell 2015. The + ! motivation seems to avoid small steps that changes the active set, because GETACT is expensive + ! in flops. However, according to a test on 20220820, removing this condition (essentially + ! replacing it with ||S|| < DELTA) improves the performance of LINCOA a bit. This may lead to + ! small steps, but tiny steps will lead to tiny reductions and trigger an exit. + newact = (jsav > 0) + if (newact) then + cycle + end if + + ! If N-NACT CG iterations has been taken in the current null space (corresponding to the + ! current "active set"), then, in theory, a stationary point in this subspace has been found. + ! If the "active set" is the true active set, then a stationary point of the + ! linearly-constrained trust region subproblem is found. So a termination is reasonable. + ! However, the "active set" is not precisely the true active set, is it? See (3.5) of Powell + ! (2015) and the comments at the beginning of the GETACT subroutine. Also, we should take into + ! account the modification after GETACT is called. + if (itercg >= n - nact) then ! ITERCG > N - NACT is impossible. + exit + end if + + ! Calculate the next search direction, which is conjugate to the previous one if ITERCG /= NACT. + ! N.B.: NACT < 0 is impossible unless GETACT is buggy; NACT = 0 can happen, particularly if + ! there is no constraint. In theory, the code for the second case below covers the first as well. + if (nact <= 0) then + pg = g + else + pg = matprod(qfac(:, nact + 1:n), matprod(g, qfac(:, nact + 1:n))) + !!MATLAB: pg = qfac(:, nact+1:n) * (g' * qfac(:, nact+1:n))'; + end if + + if (itercg == 0) then ! Iff GETACT has been called, and D is not PSD but a modified step. + beta = ZERO + else + beta = inprod(pg, hd) / dhd + end if + d = -pg + beta * d +end do + +if (present(ngetact)) then + ngetact = ngetact_loc +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(s) == n .and. all(is_finite(s)), 'SIZE(S) == N, S is finite', srname) + ! Due to rounding, it may happen that ||S|| > DELTA, but ||S|| > 2*DELTA is highly improbable. + call assert(norm(s) <= TWO * delta, '||S|| <= 2*DELTA', srname) + call assert(nact >= 0 .and. nact <= min(m, n), '0 <= NACT <= MIN(M, N)', srname) + call assert(size(qfac, 1) == n .and. size(qfac, 2) == n, 'SIZE(QFAC) == [N, N]', srname) + call assert(isorth(qfac, orthtol), 'QFAC is orthogonal', srname) + call assert(size(rfac, 1) == n .and. size(rfac, 2) == n, 'SIZE(RFAC) == [N, N]', srname) + call assert(istriu(rfac), 'RFAC is upper triangular', srname) + if (present(ngetact)) then + call assert(ngetact >= 1, 'NGETACT >= 1', srname) + end if +end if + +end subroutine trstep +!--------------------------------------------------------------------------------------------------! +! Zaikun 20220417: +! For PG, the schemes below work evidently worse than the one above in a test on 20220417. Why? +!-----------------------------------------------------------------------! +! VERSION 1: +! !pg = g - matprod(qfac(:, 1:nact), matprod(g, qfac(:, 1:nact))) +!-----------------------------------------------------------------------! +! VERSION 2: +! !if (2 * nact < n) then +! ! pg = g - matprod(qfac(:, 1:nact), matprod(g, qfac(:, 1:nact))) +! !else +! ! pg = matprod(qfac(:, nact + 1:n), matprod(g, qfac(:, nact + 1:n))) +! !end if +!-----------------------------------------------------------------------! +!--------------------------------------------------------------------------------------------------! + + +function trrad(delta_in, dnorm, eta1, eta2, gamma1, gamma2, ratio) result(delta) +!--------------------------------------------------------------------------------------------------! +! This function updates the trust region radius according to RATIO and DNORM. +!--------------------------------------------------------------------------------------------------! + +! Generic module +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan +use, non_intrinsic :: debug_mod, only : assert + +implicit none + +! Input +real(RP), intent(in) :: delta_in ! Current trust-region radius +real(RP), intent(in) :: dnorm ! Norm of current trust-region step +real(RP), intent(in) :: eta1 ! Ratio threshold for contraction +real(RP), intent(in) :: eta2 ! Ratio threshold for expansion +real(RP), intent(in) :: gamma1 ! Contraction factor +real(RP), intent(in) :: gamma2 ! Expansion factor +real(RP), intent(in) :: ratio ! Reduction ratio + +! Outputs +real(RP) :: delta + +! Local variables +character(len=*), parameter :: srname = 'TRRAD' + +! Preconditions +if (DEBUGGING) then + call assert(delta_in >= dnorm .and. dnorm > 0, 'DELTA_IN >= DNORM > 0', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + ! By the definition of RATIO in ratio.f90, RATIO cannot be NaN unless the actual reduction is + ! NaN, which should NOT happen due to the moderated extreme barrier. + call assert(.not. is_nan(ratio), 'RATIO is not NaN', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (ratio <= eta1) then + delta = gamma1 * dnorm ! Powell's UOBYQA/NEWUOA. + !delta = gamma1 * delta_in ! Powell's COBYLA/LINCOA. + !delta = min(gamma1 * delta_in, dnorm) ! Powell's BOBYQA. +elseif (ratio <= eta2) then + delta = max(gamma1 * delta_in, dnorm) ! Powell's UOBYQA/NEWUOA/BOBYQA/LINCOA +else + delta = max(gamma1 * delta_in, gamma2 * dnorm) ! Powell's NEWUOA/BOBYQA. + !delta = max(delta_in, 1.25_RP * dnorm, dnorm + rho) ! Powell's UOBYQA + !delta = max(delta_in, gamma2 * dnorm) ! Modified version. Works well for UOBYQA. + ! Powell's LINCOA code is as follows. + !delta = min(max(gamma1 * delta_in, gamma2 * dnorm), sqrt(gamma2) * delta_in) +end if + +! For noisy problems, the following may work better. +! !if (ratio <= eta1) then +! ! delta = gamma1 * dnorm +! !elseif (ratio <= eta2) then ! Ensure DELTA >= DELTA_IN +! ! delta = delta_in +! !else ! Ensure DELTA > DELTA_IN with a constant factor +! ! delta = max(delta_in * (1.0_RP + gamma2) / 2.0_RP, gamma2 * dnorm) +! !end if +! + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(delta > 0, 'DELTA > 0', srname) +end if + +end function trrad + + +end module trustregion_lincoa_mod diff --git a/examples/fortran/prima/native/lincoa/update.f90 b/examples/fortran/prima/native/lincoa/update.f90 new file mode 100644 index 000000000..978e190d1 --- /dev/null +++ b/examples/fortran/prima/native/lincoa/update.f90 @@ -0,0 +1,391 @@ +module update_lincoa_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning the updates when XPT(:, KNEW) becomes XNEW = XOPT + D. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's LINCOA code. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Friday, March 15, 2024 PM03:35:14 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: updatexf, updateq, tryqalt, updateres + + +contains + + +subroutine updatexf(knew, ximproved, f, xnew, kopt, fval, xpt) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates [XPT, FVAL, KOPT] so that XPT(:, KNEW) is updated to XNEW. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan, is_posinf + +implicit none + +! Inputs +integer(IK), intent(in) :: knew +real(RP), intent(in) :: f +real(RP), intent(in) :: xnew(:) ! XNEW(N) + +! In-outputs +integer(IK), intent(inout) :: kopt +logical, intent(in) :: ximproved +real(RP), intent(inout) :: fval(:) ! FVAL(NPT) +real(RP), intent(inout) :: xpt(:, :)! XPT(N, NPT) + +! Local variables +character(len=*), parameter :: srname = 'UPDATEXF' +integer(IK) :: n +integer(IK) :: npt + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless X is not improved', srname) + call assert(knew /= kopt .or. ximproved, 'KNEW /= KOPT unless X is improved', srname) + call assert(size(xnew) == n .and. all(is_finite(xnew)), 'SIZE(XNEW) == N, XNEW is finite', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN or +Inf', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Do essentially nothing when KNEW is 0. This can only happen after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +xpt(:, knew) = xnew +fval(knew) = f + +if (ximproved) then + kopt = knew +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt .and. all(is_finite(xpt)), & + & 'SIZE(XPT) == [N, NPT], XPT is finite', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) +end if + +end subroutine updatexf + + +subroutine updateq(idz, knew, ximproved, bmat, d, moderr, xdrop, xosav, xpt, zmat, gopt, hq, pq) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates GOPT, HQ, and PQ when XPT(:, KNEW) changes from XDROP to XNEW = XOSAV + D, +! where XOSAV is the unupdated XOPT, namely the XOPT before UPDATEXF is called. +! See Section 4 of the NEWUOA paper and that of the BOBYQA paper (there is no LINCOA paper). +! N.B.: +! XNEW is encoded in [BMAT, ZMAT, IDZ] after UPDATEH being called, and it also equals XPT(:, KNEW) +! after UPDATEXF being called. Indeed, we only need BMAT(:, KNEW) instead of the entire matrix. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : r1update, issymmetric +use, non_intrinsic :: powalg_mod, only : omega_col, hess_mul + +implicit none + +! Inputs +integer(IK), intent(in) :: idz +integer(IK), intent(in) :: knew +logical, intent(in) :: ximproved +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: d(:) ! D(:) +real(RP), intent(in) :: moderr +real(RP), intent(in) :: xdrop(:) ! XDROP(N) +real(RP), intent(in) :: xosav(:) ! XOSAV(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! In-outputs +real(RP), intent(inout) :: gopt(:) ! GOPT(N) +real(RP), intent(inout) :: hq(:, :) ! HQ(N, N) +real(RP), intent(inout) :: pq(:) ! PQ(NPT) + +! Local variables +character(len=*), parameter :: srname = 'UPDATEQ' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: pqinc(size(pq)) + +! Sizes +n = int(size(gopt), kind(n)) +npt = int(size(pq), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless X is not improved', srname) + call assert(size(xdrop) == n .and. all(is_finite(xdrop)), 'SIZE(XDROP) == N, XDROP is finite', srname) + call assert(size(xosav) == n .and. all(is_finite(xosav)), 'SIZE(XOSAV) == N, XOSAV is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Do nothing when KNEW is 0. This can only happen after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +! The unupdated model corresponding to [GOPT, HQ, PQ] interpolates F at all points in XPT except for +! XNEW. The error is MODERR = [F(XNEW)-F(XOPT)] - [Q(XNEW)-Q(XOPT)]. + +! Absorb PQ(KNEW)*XDROP*XDROP^T into the explicit part of the Hessian. +! Implement R1UPDATE properly so that it ensures that HQ is symmetric. +call r1update(hq, pq(knew), xdrop) +pq(knew) = ZERO + +! Update the implicit part of the Hessian. +pqinc = moderr * omega_col(idz, zmat, knew) +pq = pq + pqinc + +! Update the gradient, which needs the updated XPT. +gopt = gopt + moderr * bmat(:, knew) + hess_mul(xosav, xpt, pqinc) + +! Further update GOPT if XIMPROVED is TRUE, as XOPT changes from XOSAV to XNEW = XOSAV + D. +if (ximproved) then + gopt = gopt + hess_mul(d, xpt, pq, hq) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) +end if + +end subroutine updateq + + +subroutine tryqalt(idz, bmat, fval, xopt, xpt, zmat, qalt_better, gopt, pq, hq, galt, pqalt) +!--------------------------------------------------------------------------------------------------! +! This subroutine tests whether to replace Q by the alternative model, namely the model that +! minimizes the F-norm of the Hessian subject to the interpolation conditions. It first calculates +! the alternative model represented by [GALT, PQALT], and sets [GOPT, PQ, HQ] = [GALT, PQALT, 0] +! if the recent few (three) alternative models are more accurate in predicting the function value of +! XOPT + D, i.e., if ALL(QALT_BETTER) = TRUE. +!--------------------------------------------------------------------------------------------------! +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan, is_posinf +use, non_intrinsic :: linalg_mod, only : matprod, issymmetric +use, non_intrinsic :: powalg_mod, only : omega_mul, hess_mul + +implicit none + +! Inputs +integer(IK), intent(in) :: idz +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: fval(:) ! FVAL(NPT) +real(RP), intent(in) :: xopt(:) ! XOPT(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! In-outptuts +logical, intent(inout) :: qalt_better(:) ! QALT_BETTER(3) +real(RP), intent(inout) :: gopt(:) ! GOPT(N) +real(RP), intent(inout) :: pq(:) ! PQ(NPT) +real(RP), intent(inout) :: hq(:, :) ! HQ(N, N) + +! Outputs +real(RP), intent(out) :: galt(:) ! GALT(N) +real(RP), intent(out) :: pqalt(:) ! PQALT(NPT) + +! Local variables +character(len=*), parameter :: srname = 'TRYQALT' +integer(IK) :: n +integer(IK) :: npt + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(size(xopt) == n .and. all(is_finite(xopt)), 'SIZE(XOPT) == N, XOPT is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) + call assert(size(galt) == n, 'SIZE(GALT) = N', srname) + call assert(size(pqalt) == npt, 'SIZE(PQALT) = NPT', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Establish the alternative model, which is the least Frobenius norm interpolant. +pqalt = omega_mul(idz, zmat, fval) +galt = matprod(bmat(:, 1:npt), fval) + hess_mul(xopt, xpt, pqalt) + +! Replace the current model with the alternative model if ALL(QALT_BETTER) = TRUE, i.e., the +! recent few alternative models are more accurate in predicting the function value of XOPT + D. +if (all(qalt_better)) then + pq = pqalt + hq = ZERO + gopt = galt + qalt_better = .false. +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) + call assert(size(galt) == n, 'SIZE(GALT) = N', srname) + call assert(size(pqalt) == npt, 'SIZE(PQALT) = NPT', srname) +end if + +end subroutine tryqalt + + +subroutine updateres(ximproved, amat, b, delta, dnorm, xopt, rescon) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates RESCON when XOPT has been updated by a step D. +! RESCON holds information about the constraint residuals at the current trust region center XOPT. +! 1. If if B(J) - AMAT(:, J)^T*XOPT <= DELTA, then RESCON(J) = B(J) - AMAT(:, J)^T*XOPT. Note that +! RESCON >= 0 in this case, because the algorithm keeps XOPT to be feasible. +! 2. Otherwise, RESCON(J) is a negative value that B(J) - AMAT(:, J)^T*XOPT >= |RESCON(J)| >= DELTA. +! RESCON can be updated without calculating the constraints that are far from being active, so that +! we only need to evaluate the constraints that are nearly active. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : matprod, trueloc + +implicit none + +! Inputs +logical, intent(in) :: ximproved +real(RP), intent(in) :: amat(:, :) ! AMAT(N, M) +real(RP), intent(in) :: b(:) ! B(M) +real(RP), intent(in) :: delta +real(RP), intent(in) :: dnorm ! Norm of D +real(RP), intent(in) :: xopt(:) ! XOPT(N); the updated value of XOPT + +! In-outputs +real(RP), intent(inout) :: rescon(:) ! RESCON(M) + +! Local variables +character(len=*), parameter :: srname = 'UPDATERES' +integer(IK) :: m +integer(IK) :: n +logical :: mask(size(b)) +real(RP) :: ax(size(b)) + +! Sizes +m = int(size(b), kind(m)) +n = int(size(xopt), kind(n)) + +! Preconditions +if (DEBUGGING) then + call assert(size(amat, 1) == n .and. size(amat, 2) == m, 'SIZE(AMAT) == [N, M]', srname) + call assert(delta > 0, 'DELTA > 0', srname) + call assert(dnorm > 0, 'DNORM > 0', srname) + call assert(all(is_finite(xopt)), 'XOPT is finite', srname) + call assert(size(rescon) == m, 'SIZE(RESCON) == M', srname) + ! Zaikun 20221115: The following cannot pass?! Is it due to the update of DELTA? Did we + ! misunderstand Powell's definition of RESCON? + !call assert(all((rescon >= 0 .and. rescon <= delta) .or. rescon <= -delta), & + ! & '0 <= RESCON <= DELTA or RESCON <= -DELTA', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Zaikun 20221115: Currently, UPDATERES does not update RESCON unless XIMPROVED is TRUE. Shouldn't +! we do it whenever DELTA is updated? Have we MISUNDERSTOOD RESCON? +if (.not. ximproved) then + return +end if + +mask = (abs(rescon) < dnorm + delta) +ax(trueloc(mask)) = matprod(xopt, amat(:, trueloc(mask))) +where (mask) + rescon = max(b - ax, ZERO) +elsewhere + rescon = min(-abs(rescon) + dnorm, -delta) +end where +rescon(trueloc(rescon >= delta)) = -rescon(trueloc(rescon >= delta)) + +!!MATLAB: +!!mask = (abs(rescon) < delta + dnorm); +!!rescon(mask) = max(b(mask) - (xopt'*amat(:, mask))', 0); +!!rescon(~mask) = max(rescon(~mask) - dnorm, delta); +!!rescon(rescon >= delta) = -rescon(rescon >= delta); + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(rescon) == m, 'SIZE(RESCON) == M', srname) + !call assert(all((rescon >= 0 .and. rescon <= delta) .or. rescon <= -delta), & + ! & '0 <= RESCON <= DELTA or RESCON <= -DELTA', srname) +end if +end subroutine updateres + + +end module update_lincoa_mod diff --git a/examples/fortran/prima/native/newuoa/geometry.f90 b/examples/fortran/prima/native/newuoa/geometry.f90 new file mode 100644 index 000000000..de89c353e --- /dev/null +++ b/examples/fortran/prima/native/newuoa/geometry.f90 @@ -0,0 +1,888 @@ +module geometry_newuoa_mod +!--------------------------------------------------------------------------------------------------! +! This module contains subroutines concerning the geometry-improving of the interpolation set XPT. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the NEWUOA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2020 +! +! Last Modified: Sunday, April 21, 2024 PM03:20:57 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: setdrop_tr, geostep + + +contains + + +function setdrop_tr(idz, kopt, ximproved, bmat, d, delta, rho, xpt, zmat) result(knew) +!--------------------------------------------------------------------------------------------------! +! This subroutine sets KNEW to the index of the interpolation point to be deleted AFTER A TRUST +! REGION STEP. KNEW will be set in a way ensuring that the geometry of XPT is "optimal" after +! XPT(:, KNEW) is replaced with XNEW = XOPT + D, where D is the trust-region step. +! N.B.: +! 1. If XIMPROVED = TRUE, then KNEW > 0 so that XNEW is included into XPT. Otherwise, it is a bug. +! 2. If XIMPROVED = FALSE, then KNEW /= KOPT so that XPT(:, KOPT) stays. Otherwise, it is a bug. +! 3. It is tempting to take the function value into consideration when defining KNEW, for example, +! set KNEW so that FVAL(KNEW) = MAX(FVAL) as long as F(XNEW) < MAX(FVAL), unless there is a better +! choice. However, this is not a good idea, because the definition of KNEW should benefit the +! quality of the model that interpolates f at XPT. A set of points with low function values is not +! necessarily a good interpolation set. In contrast, a good interpolation set needs to include +! points with relatively high function values; otherwise, the interpolant will unlikely reflect the +! landscape of the function sufficiently. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, TENTH, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : issymmetric, trueloc +use, non_intrinsic :: powalg_mod, only : calden + +implicit none + +! Inputs +integer(IK), intent(in) :: idz +integer(IK), intent(in) :: kopt +logical, intent(in) :: ximproved +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: delta +real(RP), intent(in) :: rho +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Outputs +integer(IK) :: knew + +! Local variables +character(len=*), parameter :: srname = 'SETDROP_TR' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: den(size(xpt, 2)) +real(RP) :: distsq(size(xpt, 2)) +real(RP) :: score(size(xpt, 2)) +real(RP) :: weight(size(xpt, 2)) + +! Sizes +n = int(size(xpt, 1), kind(npt)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(delta >= rho .and. rho > 0, 'DELTA >= RHO > 0', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Calculate the distance squares between the interpolation points and the "optimal point". When +! identifying the optimal point, it is reasonable to take into account the new trust-region trial +! point XPT(:, KOPT) + D, which will become the optimal point in the next iteration if XIMPROVED +! is TRUE. Powell suggested this in +! - (56) of the UOBYQA paper, lines 276--297 of uobyqb.f, +! - (7.5) and Box 5 of the NEWUOA paper, lines 383--409 of newuob.f, +! - the last paragraph of page 26 of the BOBYQA paper, lines 435--465 of bobyqb.f. +! However, Powell's LINCOA code is different. In his code, the KNEW after a trust-region step is +! picked in lines 72--96 of the update.f for LINCOA, where DISTSQ is calculated as the square of the +! distance to XPT(KOPT, :) (Powell recorded the interpolation points in rows). However, note that +! the trust-region trial point has not been included into XPT yet --- it cannot be included without +! knowing KNEW (see lines 332-344 and 404--431 of lincob.f). Hence Powell's LINCOA code picks KNEW +! based on the distance to the un-updated "optimal point", which is unreasonable. This has been +! corrected in our implementation of LINCOA, yet it does not boost the performance. +if (ximproved) then + distsq = sum((xpt - spread(xpt(:, kopt) + d, dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - (xpt(:, kopt) + d)).^2) % d should be a column! Implicit expansion +else + distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - xpt(:, kopt)).^2) % Implicit expansion +end if + +weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**3 ! Powell's code. +! Other possible definitions of WEIGHT. +! !weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**3.5 ! This sometimes works better +! !weight = max(ONE, distsq / rho**2)**3 ! This works almost the same as Powell's code +! !weight = max(ONE, distsq / delta**2)**3 ! BOBYQA code. It does not work as well as the above. +! !weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**4 ! It does not work as well as the above. +! !weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**2 ! This works poorly. + +den = calden(kopt, bmat, d, xpt, zmat, idz) +score = weight * abs(den) + +! If the new F is not better than FVAL(KOPT), we set SCORE(KOPT) = -1 to avoid KNEW = KOPT. +if (.not. ximproved) then + score(kopt) = -ONE +end if + +! SCORE(K) is NaN implies ABS(DEN(K)) is NaN, but we want ABS(DEN) to be big. So we exclude such K. +score(trueloc(is_nan(score))) = -ONE + +knew = 0 +! The following IF works a bit better than `IF (ANY(SCORE > 0))` from Powell's BOBYQA/LINCOA code. +if (any(score > 1) .or. (ximproved .and. any(score > 0))) then ! Powell's UOBYQA and NEWUOA code + ! See (7.5) of the NEWUOA paper for the definition of KNEW in this case. + knew = int(maxloc(score, dim=1), kind(knew)) + !!MATLAB: [~, knew] = max(score); +end if + +! Powell's code does not include the following instructions. With Powell's code, if DEN consists of +! only NaN, then KNEW can be 0 even when XIMPROVED is TRUE. Here, we set KNEW to the following value, +! to make sure that the new trial point is included in the interpolation set. However, the updating +! subroutine will likely need to skip the update of the Lagrange polynomials (i.e., H), or they +! would be destroyed by the NaNs. +if ((ximproved .and. knew == 0) .or. knew < 0) then ! KNEW < 0 is impossible in theory. + knew = int(maxloc(distsq, dim=1), kind(knew)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(knew /= kopt .or. ximproved, 'KNEW /= KOPT unless XIMPROVED = TRUE', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless XIMPROVED = FALSE', srname) + ! KNEW >= 1 when XIMPROVED = TRUE unless NaN occurs in DISTSQ, which should not happen if the + ! starting point does not contain NaN and the trust-region/geometry steps never contain NaN. +end if + +end function setdrop_tr + + +function geostep(idz, knew, kopt, bmat, delbar, xpt, zmat) result(d) +!--------------------------------------------------------------------------------------------------! +! This subroutine finds a step D that intends to improve the geometry of the interpolation set when +! XPT(:, KNEW) is changed to XOPT + D, where XOPT = XPT(:, KOPT). +! +! XPT contains the current interpolation points. +! BMAT provides the last N ROWs of H. +! ZMAT and IDZ give a factorization of the first NPT by NPT sub-matrix of H. +! KNEW is the index of the interpolation point to be dropped. +! DELBAR is the trust region bound for the geometry step +! D will be set to the step from X to the new point. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, TWO, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan +use, non_intrinsic :: linalg_mod, only : issymmetric, norm +use, non_intrinsic :: powalg_mod, only : omega_col, calvlag, calbeta +implicit none + +! Inputs +integer(IK), intent(in) :: idz +integer(IK), intent(in) :: knew +integer(IK), intent(in) :: kopt +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: delbar +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Outputs +real(RP) :: d(size(xpt, 1)) ! D(N) + +! Local variables +character(len=*), parameter :: srname = 'GEOSTEP' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: alpha +real(RP) :: beta +real(RP) :: dden(size(xpt, 1)) +real(RP) :: denom +real(RP) :: denrat +real(RP) :: pqlag(size(xpt, 2)) +real(RP) :: scaling +real(RP) :: vlag(size(xpt, 1) + size(xpt, 2)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(knew >= 1 .and. knew <= npt, '1 <= KNEW <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew /= kopt, 'KNEW /= KOPT', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(delbar > 0, 'DELBAR > 0', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +d = biglag(idz, knew, bmat, delbar, xpt(:, kopt), xpt, zmat) + +! PQLAG contains the leading NPT elements of the KNEW-th column of H, and it provides the second +! derivative parameters of LFUNC. +pqlag = omega_col(idz, zmat, knew) +alpha = pqlag(knew) ! ALPHA is the KNEW-th diagonal entry of H, i.e., that of Omega. + +! Calculate VLAG and BETA for D. Indeed, only VLAG(KNEW) is needed. +vlag = calvlag(kopt, bmat, d, xpt, zmat, idz) +beta = calbeta(kopt, bmat, d, xpt, zmat, idz) +denom = alpha * beta + vlag(knew)**2 + +! If the cancellation in DENOM is unacceptable, then BIGDEN calculates an alternative model step D. +! As in (6.17) of the NEWUOA paper, DENRAT = |ALPHA*BETA + TAU^2| / TAU^2 with TAU = VLAG(KNEW). +! Powell's code does not check whether VLAG(KNEW)**2 > 0, which holds in theory. VLAG(KNEW) can +! become 0 or NaN numerically, which did happen in tests, indicating a failure of BIGLAG, because +! BIGLAG should maximize |VLAG(KNEW)|. Upon this failure, it is reasonable to call BIGDEN. For the +! same reason, we check whether BETA is NaN. Why not check ALPHA? Because BIGDEN cannot improve ALPHA. +! Powell's code takes DDEN once it is calculated. We take it only if it renders a bigger denominator. +denrat = -ONE +if (vlag(knew)**2 > 0 .and. .not. is_nan(beta)) then + denrat = abs(ONE + alpha * beta / vlag(knew)**2) +end if +! If DENRAT is NaN at this point, then ALPHA is NaN, and there is no need to call BIGDEN. +if (denrat <= 0.8_RP) then + dden = bigden(idz, knew, kopt, bmat, d, xpt, zmat) + vlag = calvlag(kopt, bmat, dden, xpt, zmat, idz) + beta = calbeta(kopt, bmat, dden, xpt, zmat, idz) + if (abs(alpha * beta + vlag(knew)**2) >= abs(denom) .or. is_nan(denom)) then + d = dden + end if +end if + +! In case D is zero or contains Inf/NaN, replace it with a displacement from XPT(:, KNEW) to +! XOPT. Powell's code does not have this. +if (sum(abs(d)) <= 0 .or. .not. is_finite(sum(abs(d)))) then + d = xpt(:, knew) - xpt(:, kopt) + scaling = delbar / norm(d) + d = max(0.6_RP * scaling, min(HALF, scaling)) * d ! 0.6: ensure |D| > DELBAR/2 +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + ! In theory, ||D|| = DELBAR. Considering rounding errors, we check that DELBAR/2 < ||D|| < 2*DELBAR. + ! It is crucial to ensure that the geometry step is nonzero. + call assert(norm(d) > HALF * delbar .and. norm(d) < TWO * delbar, 'DELBAR/2 < ||D|| < 2*DELBAR', srname) +end if + +end function geostep + + +function biglag(idz, knew, bmat, delbar, x, xpt, zmat) result(d) +!--------------------------------------------------------------------------------------------------! +! This subroutine calculates a D by approximately solving +! +! max |LFUNC(X + D)|, subject to ||D|| <= DELBAR, +! +! where LFUNC is the KNEW-th Lagrange function. See Section 6 of the NEWUOA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, QUART, TENTH, EPS, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : inprod, issymmetric, norm, project +use, non_intrinsic :: powalg_mod, only : omega_col, hess_mul +use, non_intrinsic :: univar_mod, only : circle_maxabs + +implicit none + +! Inputs +integer(IK), intent(in) :: idz +integer(IK), intent(in) :: knew +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: delbar +real(RP), intent(in) :: x(:) ! X(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Outputs +real(RP) :: d(size(xpt, 1)) ! D(N) + +! Local variables +character(len=*), parameter :: srname = 'BIGLAG' +integer(IK) :: iter +integer(IK) :: maxiter +integer(IK) :: n +integer(IK) :: npt +real(RP) :: angle +real(RP) :: cf(5) +real(RP) :: cth +real(RP) :: dd +real(RP) :: dhd +real(RP) :: dold(size(x)) +real(RP) :: gc(size(x)) +real(RP) :: gd(size(x)) +real(RP) :: gg +real(RP) :: pqlag(size(xpt, 2)) +real(RP) :: s(size(x)) +real(RP) :: scaling +real(RP) :: sp +real(RP) :: ss +real(RP) :: sth +real(RP) :: t +real(RP) :: tau ! LFUNC(X) +real(RP) :: tol +real(RP) :: w(size(x)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(knew >= 1 .and. knew <= npt, '1 <= KNEW <= NPT', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(delbar > 0, 'DELBAR > 0', srname) + call assert(size(x) == n .and. all(is_finite(x)), 'SIZE(X) == N, X is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! PQLAG contains the leading NPT elements of the KNEW-th column of H, and it provides the second +! derivative parameters of LFUNC. +pqlag = omega_col(idz, zmat, knew) + +! Set the unscaled initial D. Form the gradient of LFUNC at X, and multiply D by the Hessian of LFUNC. +d = xpt(:, knew) - x +dd = inprod(d, d) +gd = hess_mul(d, xpt, pqlag) ! GD = MATPROD(XPT, PQLAG * MATPROD(D, XPT)) + +gc = bmat(:, knew) + hess_mul(x, xpt, pqlag) ! GC = BMAT(:,KNEW) + MATPROD(XPT,PQLAG*MATPROD(X,XPT)) + +! Scale D and GD, with a sign change if needed. Set S to another vector in the initial 2-D subspace. +gg = inprod(gc, gc) +sp = inprod(d, gc) +dhd = inprod(d, gd) +scaling = delbar / sqrt(dd) +if (sp * dhd < 0) then + scaling = -scaling +end if +t = ZERO +if (sp**2 > 0.99_RP * dd * gg) then + t = ONE +end if +tau = scaling * (abs(sp) + HALF * scaling * abs(dhd)) +if (gg * delbar**2 < 1.0E-2_RP * tau**2) then + t = ONE +end if +if (is_finite(sum(abs(scaling * d)))) then + d = scaling * d + gd = scaling * gd + s = gc + t * gd + maxiter = n +else + maxiter = 0 ! Return immediately to avoid producing a D containing NaN/Inf. +end if + +tol = min(1.0E-1_RP, max(EPS**QUART, 1.0E-4_RP)) +do iter = 1, maxiter + ! Begin the iteration by overwriting S with a vector that has the required length and direction, + ! except that termination occurs if the given D and S are nearly parallel. + ! TOL is the tolerance for telling whether S and D are nearly parallel. In Powell's code, the + ! tolerance is 1.0D-4. We adapt it to the following value in case single precision is in use. + + ! Powell's code calculates S as follows. In precise arithmetic, INPROD(S, D) = 0, ||S|| = ||D||. + ! However, when DD*SS - DS**2 is tiny, the error in S can be large and hence damage these + ! equalities significantly. This did happen in tests, especially when using the single precision. + ! !ds = inprod(d, s) + ! !ss = inprod(s, s) + ! !if (dd * ss - ds**2 <= 1.0E-8_RP * dd * ss) then + ! ! exit + ! !end if + ! !denom = sqrt(dd * ss - ds**2) + ! !s = (dd * s - ds * d) / denom + + ! We calculate S as follows. It did improve the performance of NEWUOA in our test. + ss = inprod(s, s) + s = s - project(s, d) ! PROJECT(X, V) is the projection of X to SPAN(V): X'*(V/||V||)*(V/||V||) + ! N.B.: + ! 1. The condition ||S||<=TOL*SQRT(SS) below is equivalent to DS^2>=(1-TOL^2)*DD*SS in theory. + ! As shown above, Powell's code triggers an exit if DS^2>=(1-1.0E-8)*DD*SS. So our condition is + ! the same except that we take EPS into account in case single precision is in use. + ! 2. The condition below should be non-strict so that ||S|| = 0 can trigger the exit. + if (norm(s) <= tol * sqrt(ss)) then + exit + end if + s = (norm(d) / norm(s)) * s + + ! In precise arithmetic, INPROD(S, D) = 0 and ||S|| = ||D|| = DELBAR. + if (abs(inprod(d, s)) >= TENTH * norm(d) * norm(s) .or. norm(s) >= TWO * delbar) then + exit + end if + + w = hess_mul(s, xpt, pqlag) ! W = MATPROD(XPT, PQLAG * MATPROD(S, XPT)) + + ! Seek the value of the angle that maximizes ||TAU||. + ! First, calculate the coefficients of the objective function on the circle. + cf(1) = HALF * inprod(s, w) + cf(2) = inprod(d, gc) + cf(3) = inprod(s, gc) + cf(4) = HALF * inprod(d, gd) - cf(1) + cf(5) = inprod(s, gd) + ! The 50 in the line below was chosen by Powell. It works the best in tests, MAGICALLY. Larger + ! (e.g., 60, 100) or smaller (e.g., 20, 40) values will worsen the performance of NEWUOA. Why?? + angle = circle_maxabs(circle_fun_biglag, cf, 50_IK) + + ! Calculate the new D and GD. + cth = cos(angle) + sth = sin(angle) + dold = d + d = cth * d + sth * s + + ! Exit in case of Inf/NaN in D. + if (.not. is_finite(sum(abs(d)))) then + d = dold + exit + end if + + ! Test for convergence. + if (abs(circle_fun_biglag(angle, cf)) <= 1.1_RP * abs(circle_fun_biglag(ZERO, cf))) then + exit + end if + + ! Calculate GD and S. + gd = cth * gd + sth * w + s = gc + gd +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + ! In theory, ||D|| = DELBAR. Considering rounding errors, we check that DELBAR/2 < ||D|| < 2*DELBAR. + ! It is crucial to ensure that the geometry step is nonzero. + call assert(norm(d) > HALF * delbar .and. norm(d) < TWO * delbar, 'DELBAR/2 < ||D|| < 2*DELBAR', srname) +end if + +end function biglag + + +function bigden(idz, knew, kopt, bmat, d0, xpt, zmat) result(d) +!--------------------------------------------------------------------------------------------------! +! BIGDEN calculates a D by approximately solving +! +! max |SIGMA(XOPT + D)|, subject to ||D|| <= DELBAR, +! +! where SIGMA is the denominator sigma in the updating formula (4.11)--(4.12) for H, which is the +! inverse of the coefficient matrix for the interpolation system (see (3.12)). Indeed, each column +! of H corresponds to a Lagrange basis function of the interpolation problem. See Section 6 of the +! NEWUOA paper. +! N.B.: +! In Powell's code, BIGDEN calculates also the VLAG and BETA for the selected D. Here, to reduce the +! coupling of code, we return only D but compute VLAG and BETA outside by calling VLAGBETA. It makes +! no difference mathematically, but the computed VLAG/BETA will change slightly due to rounding. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, TENTH, QUART, EPS, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : inprod, matprod, issymmetric, norm, project +use, non_intrinsic :: powalg_mod, only : omega_col, omega_mul +use, non_intrinsic :: univar_mod, only : circle_maxabs + +implicit none + +! Inputs +integer(IK), intent(in) :: idz +integer(IK), intent(in) :: knew +integer(IK), intent(in) :: kopt +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT+N) +real(RP), intent(in) :: d0(:) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Outputs +real(RP) :: d(size(xpt, 1)) ! D(N) + +! Local variable +character(len=*), parameter :: srname = 'BIGDEN' +integer(IK) :: iter +integer(IK) :: j +integer(IK) :: k +integer(IK) :: n +integer(IK) :: npt +integer(IK) :: nw +real(RP) :: alpha +real(RP) :: angle +real(RP) :: dd +real(RP) :: delbar +real(RP) :: den(9) +real(RP) :: denex(9) +real(RP) :: denmax +real(RP) :: densav +real(RP) :: dold(size(xpt, 1)) +real(RP) :: ds +real(RP) :: dstemp(size(xpt, 2)) +real(RP) :: dtest +real(RP) :: par(5) +real(RP) :: pqlag(size(xpt, 2)) +real(RP) :: prod(size(xpt, 1) + size(xpt, 2), 5) +real(RP) :: s(size(xpt, 1)) +real(RP) :: ss +real(RP) :: sstemp(size(xpt, 2)) +real(RP) :: tau +real(RP) :: tempa +real(RP) :: tempb +real(RP) :: tempc +real(RP) :: tol +real(RP) :: v(size(xpt, 2)) +real(RP) :: vlag(size(xpt, 1) + size(xpt, 2)) +real(RP) :: w(size(xpt, 1) + size(xpt, 2), 5) +real(RP) :: x(size(xpt, 1)) +real(RP) :: xd +real(RP) :: xptemp(size(xpt, 1), size(xpt, 2)) +real(RP) :: xs +real(RP) :: xsq +real(RP) :: y(size(xpt, 1)) +real(RP) :: yd +real(RP) :: ysq + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(knew >= 1 .and. knew <= npt, '1 <= KNEW <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew /= kopt, 'KNEW /= KOPT', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(d0) == n .and. all(is_finite(d0)), 'SIZE(D0) == N, D0 is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +x = xpt(:, kopt) ! For simplicity, we use X to denote XOPT. + +delbar = norm(d0) ! In theory, ||D0|| = DELBAR. + +! PQLAG contains the leading NPT elements of the KNEW-th column of H, and it provides the second +! derivative parameters of LFUNC. +pqlag = omega_col(idz, zmat, knew) +alpha = pqlag(knew) ! ALPHA is the KNEW-th diagonal entry of H, i.e., that of Omega. + +! The initial search direction D is taken from the last call of BIGLAG, and the initial S is set +! below, usually to the direction from X to X_KNEW, but a different direction to an interpolation +! point may be chosen, in order to prevent S from being nearly parallel to D. +d = d0 +dd = inprod(d, d) +s = xpt(:, knew) - x +ds = inprod(d, s) +ss = inprod(s, s) +xsq = inprod(x, x) + +if (.not. (ds**2 <= 0.99_RP * dd * ss)) then + ! `.NOT. (A <= B)` differs from `A > B`. The former holds iff A > B or {A, B} contains NaN. + dtest = ds**2 / ss + xptemp = xpt - spread(x, dim=2, ncopies=npt) + !!MATLAB: xptemp = xpt - x % x should be a column! Implicit expansion + !----------------------------------------------------------------! + !---------!dstemp = matprod(d, xpt) - inprod(x, d) !-------------! + dstemp = matprod(d, xptemp) + !----------------------------------------------------------------! + sstemp = sum((xptemp)**2, dim=1) + + dstemp(kopt) = TWO * ds + ONE + sstemp(kopt) = ss + k = int(minloc(dstemp**2 / sstemp, dim=1), kind(k)) + ! K can be 0 due to NaN. In that case, set K = KNEW. Otherwise, memory errors will occur. + if (k == 0) then + k = knew + end if + if ((.not. (dstemp(k)**2 / sstemp(k) >= dtest)) .and. k /= kopt) then + ! `.NOT. (A >= B)` differs from `A < B`. The former holds iff A < B or {A, B} contains NaN. + ! Although unlikely, if NaN occurs, it may happen that K = KOPT. + s = xpt(:, k) - x + end if +end if + +densav = ZERO + +tol = min(1.0E-1_RP, max(EPS**QUART, 1.0E-4_RP)) +do iter = 1, n + ! Begin the iteration by overwriting S with a vector that has the required length and direction. + ! TOL is the tolerance for telling whether S and D are nearly parallel. In Powell's code, the + ! tolerance is 1.0D-4. We adapt it to the following value in case single precision is in use. + + ! Powell's code calculates S as follows. In precise arithmetic, INPROD(S, D) = 0, ||S|| = ||D||. + ! However, when DD*SS - DS**2 is tiny, the error in S can be large and hence damage these + ! equalities significantly. This did happen in tests, especially when using the single precision. + ! !ds = inprod(d, s) + ! !ss = inprod(s, s) + ! !ssden = dd * ss - ds**2 + ! !if (ssden < 1.0E-8_RP * dd * ss) then + ! ! exit + ! !end if + ! !s = (ONE / sqrt(ssden)) * (dd * s - ds * d) + + ! We calculate S as below. It did improve the performance of NEWUOA in our test. + ss = inprod(s, s) + s = s - project(s, d) ! PROJECT(X, V) is the projection of X to SPAN(V): X'*(V/||V||)*(V/||V||) + ! N.B.: + ! 1. The condition ||S||<=TOL*SQRT(SS) below is equivalent to DS^2>=(1-TOL^2)*DD*SS in theory. + ! As shown above, Powell's code triggers an exit if DS^2>=(1-1.0E-8)*DD*SS. So our condition is + ! the same except that we take EPS into account in case single precision is in use. + ! 2. The condition below should be non-strict so that ||S|| = 0 can trigger the exit. + if (norm(s) <= tol * sqrt(ss)) then + exit + end if + s = (s / norm(s)) * norm(d) + ! In precise arithmetic, INPROD(S, D) = 0 and ||S|| = ||D|| = DELBAR = ||D0||. + if (abs(inprod(d, s)) >= TENTH * norm(d) * norm(s) .or. norm(s) >= TWO * delbar) then + exit + end if + + ! Set the coefficients of the first two terms of BETA. + xd = inprod(x, d) + xs = inprod(x, s) + dd = inprod(d, d) + tempa = HALF * xd * xd + tempb = HALF * xs * xs + den(1) = dd * (xsq + HALF * dd) + tempa + tempb + den(2) = TWO * xd * dd + den(3) = TWO * xs * dd + den(4) = tempa - tempb + den(5) = xd * xs + den(6:9) = ZERO + + ! Put the coefficients of WCHECK in W. + do k = 1, npt + tempa = inprod(xpt(:, k), d) + tempb = inprod(xpt(:, k), s) + tempc = inprod(xpt(:, k), x) + w(k, 1) = QUART * (tempa**2 + tempb**2) + w(k, 2) = tempa * tempc + w(k, 3) = tempb * tempc + w(k, 4) = QUART * (tempa**2 - tempb**2) + w(k, 5) = HALF * tempa * tempb + end do + w(npt + 1:npt + n, 1:5) = ZERO + w(npt + 1:npt + n, 2) = d + w(npt + 1:npt + n, 3) = s + + ! Put the coefficients of THETA*WCHECK in PROD. + do j = 1, 5 + prod(1:npt, j) = omega_mul(idz, zmat, w(1:npt, j)) + nw = npt + if (j == 2 .or. j == 3) then + prod(1:npt, j) = prod(1:npt, j) + matprod(w(npt + 1:npt + n, j), bmat(:, 1:npt)) + nw = npt + n + end if + prod(npt + 1:npt + n, j) = matprod(bmat(:, 1:nw), w(1:nw, j)) + end do + + ! Include in DEN the part of BETA that depends on THETA. + do k = 1, npt + n + par(1:5) = HALF * prod(k, 1:5) * w(k, 1:5) + den(1) = den(1) - par(1) - sum(par(1:5)) + tempa = prod(k, 1) * w(k, 2) + prod(k, 2) * w(k, 1) + tempb = prod(k, 2) * w(k, 4) + prod(k, 4) * w(k, 2) + tempc = prod(k, 3) * w(k, 5) + prod(k, 5) * w(k, 3) + den(2) = den(2) - tempa - HALF * (tempb + tempc) + den(6) = den(6) - HALF * (tempb - tempc) + tempa = prod(k, 1) * w(k, 3) + prod(k, 3) * w(k, 1) + tempb = prod(k, 2) * w(k, 5) + prod(k, 5) * w(k, 2) + tempc = prod(k, 3) * w(k, 4) + prod(k, 4) * w(k, 3) + den(3) = den(3) - tempa - HALF * (tempb - tempc) + den(7) = den(7) - HALF * (tempb + tempc) + tempa = prod(k, 1) * w(k, 4) + prod(k, 4) * w(k, 1) + den(4) = den(4) - tempa - par(2) + par(3) + tempa = prod(k, 1) * w(k, 5) + prod(k, 5) * w(k, 1) + tempb = prod(k, 2) * w(k, 3) + prod(k, 3) * w(k, 2) + den(5) = den(5) - tempa - HALF * tempb + den(8) = den(8) - par(4) + par(5) + tempa = prod(k, 4) * w(k, 5) + prod(k, 5) * w(k, 4) + den(9) = den(9) - HALF * tempa + end do + + par(1:5) = HALF * prod(knew, 1:5)**2 + denex(1) = alpha * den(1) + par(1) + sum(par(1:5)) + tempa = TWO * prod(knew, 1) * prod(knew, 2) + tempb = prod(knew, 2) * prod(knew, 4) + tempc = prod(knew, 3) * prod(knew, 5) + denex(2) = alpha * den(2) + tempa + tempb + tempc + denex(6) = alpha * den(6) + tempb - tempc + tempa = TWO * prod(knew, 1) * prod(knew, 3) + tempb = prod(knew, 2) * prod(knew, 5) + tempc = prod(knew, 3) * prod(knew, 4) + denex(3) = alpha * den(3) + tempa + tempb - tempc + denex(7) = alpha * den(7) + tempb + tempc + tempa = TWO * prod(knew, 1) * prod(knew, 4) + denex(4) = alpha * den(4) + tempa + par(2) - par(3) + tempa = TWO * prod(knew, 1) * prod(knew, 5) + denex(5) = alpha * den(5) + tempa + prod(knew, 2) * prod(knew, 3) + denex(8) = alpha * den(8) + par(4) - par(5) + denex(9) = alpha * den(9) + prod(knew, 4) * prod(knew, 5) + + ! Seek the value of the angle that maximizes the |DENOM|. + angle = circle_maxabs(circle_fun_bigden, denex, 50_IK) + + ! Calculate the new D. + dold = d + d = cos(angle) * d + sin(angle) * s + + ! Exit in case of Inf/NaN in D. + if (.not. is_finite(sum(abs(d)))) then + d = dold + exit + end if + + ! Test for convergence. + if (iter > 1) then + densav = max(densav, circle_fun_bigden(ZERO, denex)) + end if + denmax = circle_fun_bigden(angle, denex) + if (abs(denmax) <= 1.1_RP * abs(densav)) then + exit + end if + densav = denmax + + ! Set S to HALF the gradient of the denominator with respect to D. First, calculate the new VLAG. + par = [ONE, cos(angle), sin(angle), cos(2.0_RP * angle), sin(2.0_RP * angle)] + vlag = matprod(prod, par) + tau = vlag(knew) + y = x + d + yd = inprod(y, d) + ysq = inprod(y, y) + v = (tau * pqlag - alpha * vlag(1:npt)) * matprod(y, xpt) + s = tau * bmat(:, knew) + alpha * (yd * x + ysq * d - vlag(npt + 1:npt + n)) + s = s + matprod(xpt, v) +end do + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + ! In theory, ||D|| = DELBAR. Considering rounding errors, we check that DELBAR/2 < ||D|| < 2*DELBAR. + ! It is crucial to ensure that the geometry step is nonzero. + call assert(norm(d) > HALF * delbar .and. norm(d) < TWO * delbar, 'DELBAR/2 < ||D|| < 2*DELBAR', srname) +end if + +end function bigden + + +function circle_fun_biglag(theta, args) result(f) +!--------------------------------------------------------------------------------------------------! +! This function defines the objective function of the 2-dimensional search on a circle in BIGLAG. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none +! Inputs +real(RP), intent(in) :: theta +real(RP), intent(in) :: args(:) + +! Outputs +real(RP) :: f + +! Local variables +character(len=*), parameter :: srname = 'CIRCLE_FUN_BIGLAG' +real(RP) :: cth +real(RP) :: sth + +! Preconditions +if (DEBUGGING) then + call assert(size(args) == 5, 'SIZE(ARGS) == 5', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +cth = cos(theta) +sth = sin(theta) +f = args(1) + (args(2) + args(4) * cth) * cth + (args(3) + args(5) * cth) * sth + +!====================! +! Calculation ends ! +!====================! +end function circle_fun_biglag + + +function circle_fun_bigden(theta, args) result(f) +!--------------------------------------------------------------------------------------------------! +! This function defines the objective function of the 2-dimensional search on a circle in BIGDEN. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, ONE, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: linalg_mod, only : inprod + +implicit none + +! Inputs +real(RP), intent(in) :: theta +real(RP), intent(in) :: args(:) + +! Outputs +real(RP) :: f + +! Local variables +character(len=*), parameter :: srname = 'CIRCLE_FUN_BIGDEN' +real(RP) :: par(size(args)) + +! Preconditions +if (DEBUGGING) then + call assert(size(args) == 9, 'SIZE(ARGS) == 9', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +par(1) = ONE +par(2:8:2) = cos(theta*[1.0_RP, 2.0_RP, 3.0_RP, 4.0_RP]) +par(3:9:2) = sin(theta*[1.0_RP, 2.0_RP, 3.0_RP, 4.0_RP]) +f = inprod(args, par) + +!====================! +! Calculation ends ! +!====================! +end function circle_fun_bigden + + +end module geometry_newuoa_mod diff --git a/examples/fortran/prima/native/newuoa/initialize.f90 b/examples/fortran/prima/native/newuoa/initialize.f90 new file mode 100644 index 000000000..3d1a2015b --- /dev/null +++ b/examples/fortran/prima/native/newuoa/initialize.f90 @@ -0,0 +1,519 @@ +module initialize_newuoa_mod +!--------------------------------------------------------------------------------------------------! +! This module performs the initialization of NEWUOA, described in Section 3 of the NEWUOA paper. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the NEWUOA paper. +! +! Started: July 2020 +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Last Modified: Tue 10 Feb 2026 01:56:05 PM CET +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: initxf, initq, inith + + +contains + + +subroutine initxf(calfun, iprint, maxfun, ftarget, rhobeg, x0, ij, kopt, nf, fhist, fval, xbase, & + & xhist, xpt, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine does the initialization about the interpolation points & their function values. +! +! N.B.: +! 1. Remark on IJ: +! If NPT <= 2*N + 1, then IJ is empty. Assume that NPT >= 2*N + 2. Then SIZE(IJ) = [2, NPT-2*N-1]. +! IJ contains integers between 1 and 2*N. For each K > 2*N + 1, XPT(:, K) is +! XPT(:, IJ(1, K) + 1) + XPT(:, IJ(2, K) + 1). The 1 in IJ + 1 comes from the fact that XPT(:, 1) +! corresponds to the base point XBASE. Let I = IJ(1, K) if such a number is <= N; otherwise, let +! I = IJ(1, K) - N; define J by IJ(2, K) in a similar fashion. Then all the entries of XPT(:, K) +! are zero except that the I and J entries are RHOBEG or -RHOBEG. Indeed, XPT(I, K) is RHOBEG if +! IJ(1, K) <= N and -RHOBEG otherwise; XPT(J, K) is similar. Consequently, the Hessian of the +! quadratic model will get a possibly nonzero (I, J) entry. In the code, IJ is defined according to +! Powell's original code as well as Section 3 of the NEWUOA paper and (2.4) of the BOBYQA paper. +! 2. At return, +! INFO = INFO_DFT: initialization finishes normally +! INFO = FTARGET_ACHIEVED: return because F <= FTARGET +! INFO = NAN_INF_X: return because X contains NaN +! INFO = NAN_INF_F: return because F is either NaN or +Inf +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: evaluate_mod, only : evaluate +use, non_intrinsic :: history_mod, only : savehist +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan, is_posinf +use, non_intrinsic :: infos_mod, only : INFO_DFT +use, non_intrinsic :: linalg_mod, only : eye +use, non_intrinsic :: message_mod, only : fmsg +use, non_intrinsic :: pintrf_mod, only : OBJ +use, non_intrinsic :: powalg_mod, only : setij + +implicit none + +! Inputs +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfun +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: x0(:) ! X0(N) + +! Outputs +integer(IK), intent(out) :: ij(:, :) ! IJ(2, MAX(0_IK, NPT-2*N-1_IK)) +integer(IK), intent(out) :: info +integer(IK), intent(out) :: kopt +integer(IK), intent(out) :: nf +real(RP), intent(out) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out) :: fval(:) ! FVAL(NPT) +real(RP), intent(out) :: xbase(:) ! XBASE(N) +real(RP), intent(out) :: xhist(:, :) ! XHIST(N, MAXXHIST) +real(RP), intent(out) :: xpt(:, :) ! XPT(N, NPT) + +! Local variables +character(len=*), parameter :: solver = 'NEWUOA' +character(len=*), parameter :: srname = 'INITXF' +integer(IK) :: k +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: npt +integer(IK) :: subinfo +logical :: evaluated(size(fval)) +real(RP) :: f +real(RP) :: x(size(x0)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxhist = max(maxxhist, maxfhist) + +! Preconditions +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(maxfun >= npt + 1, 'MAXFUN >= NPT + 1', srname) + call assert(maxhist >= 0 .and. maxhist <= maxfun, '0 <= MAXHIST <= MAXFUN', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(size(fval) == npt, 'SIZE(FVAL) == NPT', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(rhobeg > 0, 'RHOBEG > 0', srname) + call assert(size(x0) == n .and. all(is_finite(x0)), 'SIZE(X0) == N, X0 is finite', srname) + call assert(size(xbase) == n, 'SIZE(XBASE) == N', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialize INFO to the default value. At return, an INFO different from this value will indicate +! an abnormal return. +info = INFO_DFT + +! Initialize XBASE to X0. +xbase = x0 + +! EVALUATED is a boolean array with EVALUATED(I) indicating whether the function value of the I-th +! interpolation point has been evaluated. We need it for a portable counting of the number of +! function evaluations, especially if the loop is conducted asynchronously. However, the loop here +! is not fully parallelizable if NPT>2N+1, as the definition XPT(;, 2N+2:end) involves FVAL(1:2N+1). +evaluated = .false. + +! Initialize XHIST, FHIST, and FVAL. Otherwise, compilers may complain that they are not +! (completely) initialized if the initialization aborts due to abnormality (see CHECKEXIT). +! N.B.: 1. Initializing them to NaN would be more reasonable (NaN is not available in Fortran). +! 2. Do not initialize the models if the current initialization aborts due to abnormality. Otherwise, +! errors or exceptions may occur, as FVAL and XPT etc are uninitialized. +xhist = -REALMAX +fhist = REALMAX +fval = REALMAX + +! Initialize XPT(:, 1: MIN(2*N + 1, NPT)). +xpt(:, 1) = ZERO +xpt(:, 2:n + 1) = rhobeg * eye(n) +! After the following line, XPT(:, 2*N+2 : NPT) = ZERO if it is nonempty. It will be revised later +! according to FVAL(2 : 2*N + 1). +xpt(:, n + 2:npt) = -rhobeg * eye(n, npt - n - 1_IK) + +! Set FVAL(1 : min(2*N + 1, NPT)) by evaluating F. Totally parallelizable except for FMSG. +do k = 1, min(npt, 2_IK * n + 1_IK) + x = xpt(:, k) + xbase + call evaluate(calfun, x, f) + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Initialization', iprint, k, rhobeg, f, x) + ! Save X and F into the history. + call savehist(k, x, xhist, f, fhist) + + evaluated(k) = .true. + fval(k) = f + + ! Check whether to exit. + subinfo = checkexit(maxfun, k, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if +end do + +! Set IJ. +! In general, when NPT = (N+1)*(N+2)/2, we can set IJ(:, 1 : NPT - (2*N+1)) to ANY permutation +! of {{I, J} : 1 <= I /= J <= N}; when NPT < (N+1)*(N+2)/2, we can set it to the first NPT - (2*N+1) +! elements of such a permutation. The following IJ is defined according to Powell's code. See also +! Section 3 of the NEWUOA paper and (2.4) of the BOBYQA paper. +ij = setij(n, npt) + +! Further revise IJ according to FVAL(2 : 2*N + 1). +! N.B.: +! 1. For each K below, the following lines revises IJ(:, K) as follows: +! change IJ(1, K) to IJ(1, K) + N if FVAL(IJ(1, K) + N + 1) < FVAL(IJ(1, K) + 1); +! change IJ(2, K) to IJ(2, K) + N if FVAL(IJ(2, K) + N + 1) < FVAL(IJ(2, K) + 1). +! The 1 in IJ + 1 comes from the fact that XPT(:, 1) corresponds to XBASE. +! 2. The idea of this revision is as follows: Let [I, J] = IJ(:, K) with the IJ BEFORE the revision; +! XPT(:, K) is the sum of either {XPT(:, I+1) or XPT(:, I+N+1)} + {XPT(:, J+1) or XPT(:, J+N+1)}, +! each choice being made in favor of the point that has a lower function value, with the hope that +! such a choice will more likely render an XPT(:, K) with a lower function value. +! 3. This revision is OPTIONAL. Due to this revision, the definition of XPT(:, 2*N + 2 : NPT) relies +! on FVAL(2 : 2*N + 1), and it is the sole origin of the such dependency. If we remove the revision +! IJ, then the evaluations of FVAL(1 : NPT) can be merged, and they are totally PARALLELIZABLE; this +! can be beneficial if the function evaluations are expensive, which is likely the case. +where (fval(ij(1, :) + n + 1) < fval(ij(1, :) + 1)) ij(1, :) = ij(1, :) + n +where (fval(ij(2, :) + n + 1) < fval(ij(2, :) + 1)) ij(2, :) = ij(2, :) + n +! MATLAB (but not Fortran) can index a vector by a 2D array of indices, thus the MATLAB code is +!!MATLAB: ij(fval(ij + n + 1) < fval(ij + 1)) = ij(fval(ij + n + 1) < fval(ij + 1)) + n; + +! Set XPT(:, 2*N + 2 : NPT). It depends on IJ and hence on FVAL(2 : 2*N + 1). Indeed, XPT(:, K) has +! only two nonzeros for each K >= 2*N+2. +xpt(:, 2 * n + 2:npt) = xpt(:, ij(1, :) + 1) + xpt(:, ij(2, :) + 1) + +! Set FVAL(2*N + 2 : NPT) by evaluating F. Totally parallelizable except for FMSG. +if (info == INFO_DFT) then + do k = 2_IK * n + 2_IK, npt + x = xpt(:, k) + xbase + call evaluate(calfun, x, f) + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Initialization', iprint, k, rhobeg, f, x) + ! Save X and F into the history. + call savehist(k, x, xhist, f, fhist) + + evaluated(k) = .true. + fval(k) = f + + ! Check whether to exit. + subinfo = checkexit(maxfun, k, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + end do +end if + +! Set NF, KOPT +nf = int(count(evaluated), kind(nf)) !!MATLAB: nf = sum(evaluated); +kopt = int(minloc(fval, mask=evaluated, dim=1), kind(kopt)) +!!MATLAB: fopt = min(fval(evaluated)); kopt = find(evaluated & ~(fval > fopt), 1, 'first') + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(all(ij >= 1 .and. ij <= 2 * n), '1 <= IJ <= 2*N', srname) + call assert(all(ij(1, :) /= ij(2, :)), 'IJ(1, :) /= IJ(:, 2)', srname) + call assert(nf <= npt, 'NF <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= nf, '1 <= KOPT <= NF', srname) + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(fval) == npt .and. .not. any(evaluated .and. (is_nan(fval) .or. is_posinf(fval))), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(.not. any(evaluated .and. fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) +end if + +end subroutine initxf + + +subroutine initq(ij, fval, xpt, gopt, hq, pq, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine initializes the quadratic model represented by [GOPT, HQ, PQ] so that its gradient +! at XBASE + XPT(:,KOPT) is GOPT; its Hessian is HQ + sum_{K=1}^NPT PQ(K)*XPT(:, K)*XPT(:, K)'. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: infos_mod, only : INFO_DFT, NAN_INF_MODEL +use, non_intrinsic :: linalg_mod, only : matprod, issymmetric + +implicit none + +! Inputs +integer(IK), intent(in) :: ij(:, :) ! IJ(2, MAX(0_IK, NPT - 2_IK * N - 1_IK)) +real(RP), intent(in) :: fval(:) ! FVAL(NPT) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +integer(IK), intent(out), optional :: info +real(RP), intent(out) :: gopt(:) ! GOPT(N) +real(RP), intent(out) :: hq(:, :) ! HQ(N, N) +real(RP), intent(out) :: pq(:) ! PQ(NPT) + +! Local variables +character(len=*), parameter :: srname = 'INITQ' +integer(IK) :: i +integer(IK) :: j +integer(IK) :: k +integer(IK) :: kopt +integer(IK) :: n +integer(IK) :: ndiag +integer(IK) :: npt +real(RP) :: fbase +real(RP) :: rhobeg +real(RP) :: xi +real(RP) :: xj + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(all(ij >= 1 .and. ij <= 2 * n), '1 <= IJ <= 2*N', srname) + call assert(all(ij(1, :) /= ij(2, :)), 'IJ(1, :) /= IJ(2, :)', srname) + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. size(hq, 2) == n, 'SIZE(HQ) = [N, N]', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +rhobeg = maxval(abs(xpt(:, 2))) ! Read RHOBEG from XPT. +fbase = fval(1) ! FBASE is the function value at XBASE. + +! Set GOPT by the forward difference. +gopt(1:n) = (fval(2:n + 1) - fbase) / rhobeg + +! The interpolation conditions decide GOPT(1:NDIAG) and the first NDIAG diagonal 2nd derivatives of +! the initial quadratic model by a quadratic interpolation on three points, which is equivalent to +! the central finite difference. +ndiag = min(npt - n - 1_IK, n) + +! Revise GOPT(1:NDIAG) to the value provided by the central finite difference. +gopt(1:ndiag) = HALF * (gopt(1:ndiag) + (fbase - fval(n + 2:n + 1 + ndiag)) / rhobeg) + +! Set the diagonal of HQ by the 2nd-order central finite difference. If we do this before the +! revision of GOPT(1:NDIAG), we can avoid the calculation of FVAL(K + 1) - FBASE) / RHOBEG. But we +! prefer to decouple the initialization of GOPT and HQ. We are not concerned by this amount of flops. +hq = ZERO +do k = 1, ndiag + hq(k, k) = ((fval(k + 1) - fbase) / rhobeg - (fbase - fval(k + n + 1)) / rhobeg) / rhobeg +end do +!!MATLAB: +!!hdiag = ((fval(2 : ndiag+1) - fbase) / rhobeg - (fbase - fval(n+2 : n+ndiag+1)) / rhobeg) / rhobeg +!!hq(1:ndiag, 1:ndiag) = diag(hdiag) + +! When NPT > 2*N + 1, set the off-diagonal entries of HQ. +do k = 1, npt - 2_IK * n - 1_IK + ! With the I, J, XI, and XJ defined below, we have + ! FVAL(K+2*n+1) = F(XBASE + XI*e_I + XJ*e_J), + ! FVAL(IJ(1, K) + 1) = F(XBASE + XI*e_I), + ! FVAL(IJ(2, K) + 1) = F(XBASE + XJ*e_J). + ! The 1 in IJ + 1 comes from the fact that XPT(:, 1) corresponds to XBASE. + ! Thus the HQ(I,J) defined below approximates frac{partial^2}{partial X_I partial X_J} F(XBASE). + ! N.B.: Here, exchanging I and J will not lead to any change in precise arithmetic. Powell's + ! code exchanges I and J if needed to ensure that I > J. This is because Powell's code saves HQ + ! as a 1D array that contains the lower triangular part of this symmetric matrix. + i = modulo(ij(1, k) - 1_IK, n) + 1_IK + j = modulo(ij(2, k) - 1_IK, n) + 1_IK + xi = xpt(i, k + 2 * n + 1) + xj = xpt(j, k + 2 * n + 1) + hq(i, j) = (fbase - fval(ij(1, k) + 1) - fval(ij(2, k) + 1) + fval(k + 2 * n + 1)) / (xi * xj) + hq(j, i) = hq(i, j) +end do + +kopt = int(minloc(fval, dim=1), kind(kopt)) +if (kopt /= 1) then + gopt = gopt + matprod(hq, xpt(:, kopt)) +end if + +pq = ZERO + +if (present(info)) then + if (any(is_nan(gopt)) .or. any(is_nan(hq))) then + info = NAN_INF_MODEL + else + info = INFO_DFT + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) +end if + +end subroutine initq + + +subroutine inith(ij, xpt, idz, bmat, zmat, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine initializes [IDZ, BMAT, ZMAT] which represents the matrix H in (3.12) of the +! NEWUOA paper (see also (2.7) of the BOBYQA paper). +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, NAN_INF_MODEL +use, non_intrinsic :: linalg_mod, only : issymmetric, eye +!use, non_intrinsic :: powalg_mod, only : errh + +implicit none + +! Inputs +integer(IK), intent(in) :: ij(:, :) ! IJ(2, MAX(0_IK, NPT - 2_IK * N - 1_IK)) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +! N.B.: XPT is essentially only used for debugging, to test the error in the initial H. The initial +! ZMAT and BMAT are completely defined by RHOBEG and IJ. + +! Outputs +integer(IK), intent(out), optional :: info +integer(IK), intent(out) :: idz +real(RP), intent(out) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(out) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! Local variables +character(len=*), parameter :: srname = 'INITH' +integer(IK) :: k +integer(IK) :: n +integer(IK) :: npt +real(RP) :: recip +real(RP) :: reciq +real(RP) :: rhobeg +real(RP) :: rhosq + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(size(ij, 1) == 2 .and. size(ij, 2) == max(0_IK, npt - 2_IK * n - 1_IK), & + & 'SIZE(IJ) == [2, NPT - 2*N - 1]', srname) + call assert(all(ij >= 1 .and. ij <= 2 * n), '1 <= IJ <= 2*N', srname) + call assert(all(ij(1, :) /= ij(2, :)), 'IJ(1, :) /= IJ(2, :)', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +rhobeg = maxval(abs(xpt(:, 2))) ! Read RHOBEG from XPT. +rhosq = rhobeg**2 + +! Set BMAT. +recip = ONE / rhobeg +reciq = HALF / rhobeg +bmat = ZERO +if (npt <= 2 * n + 1) then + ! Set BMAT(1 : NPT-N-1, :) + bmat(1:npt - n - 1, 2:npt - n) = reciq * eye(npt - n - 1_IK) + bmat(1:npt - n - 1, n + 2:npt) = -reciq * eye(npt - n - 1_IK) + ! Set BMAT(NPT-N : N, :) + bmat(npt - n:n, 1) = -recip + bmat(npt - n:n, npt - n + 1:n + 1) = recip * eye(2_IK * n - npt + 1_IK) + bmat(npt - n:n, 2 * npt - n:npt + n) = -(HALF * rhosq) * eye(2_IK * n - npt + 1_IK) +else + bmat(:, 2:n + 1) = reciq * eye(n) + bmat(:, n + 2:2 * n + 1) = -reciq * eye(n) +end if + +! Set ZMAT. +recip = ONE / rhosq +reciq = sqrt(HALF) / rhosq +zmat = ZERO +if (npt <= 2 * n + 1) then + zmat(1, :) = -reciq - reciq + zmat(2:npt - n, :) = reciq * eye(npt - n - 1_IK) + zmat(n + 2:npt, :) = reciq * eye(npt - n - 1_IK) +else + ! Set ZMAT(:, 1:N). + zmat(1, 1:n) = -reciq - reciq + zmat(2:n + 1, 1:n) = reciq * eye(n) + zmat(n + 2:2 * n + 1, 1:n) = reciq * eye(n) + ! Set ZMAT(:, N+1 : NPT-N-1). + zmat(1, n + 1:npt - n - 1) = recip + zmat(2 * n + 2:npt, n + 1:npt - n - 1) = recip * eye(npt - 2_IK * n - 1_IK) + do k = 1, npt - 2_IK * n - 1_IK + zmat(ij(:, k) + 1, k + n) = -recip + end do +end if + +! Set IDZ. +idz = 1 + +if (present(info)) then + if (any(is_nan(bmat)) .or. any(is_nan(zmat))) then + info = NAN_INF_MODEL + else + info = INFO_DFT + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + !call assert(errh(idz, bmat, zmat, xpt) <= max(1.0E-3_RP, 1.0E2_RP * real(npt, RP) * EPS), & + ! & '[IDZ, BMA, ZMAT] represents H = W^{-1}', srname) +end if + +end subroutine inith + + +end module initialize_newuoa_mod diff --git a/examples/fortran/prima/native/newuoa/newuoa.f90 b/examples/fortran/prima/native/newuoa/newuoa.f90 new file mode 100644 index 000000000..7046c3279 --- /dev/null +++ b/examples/fortran/prima/native/newuoa/newuoa.f90 @@ -0,0 +1,421 @@ +module newuoa_mod +!--------------------------------------------------------------------------------------------------! +! NEWUOA_MOD is a module providing the reference implementation of Powell's NEWUOA algorithm in +! +! M. J. D. Powell, The NEWUOA software for unconstrained optimization without derivatives, In Large- +! Scale Nonlinear Optimization, eds. G. Di Pillo and M. Roma, 255--297, Springer, New York, 2006 +! +! NEWUOA approximately solves +! +! min F(X), +! +! where X is a vector of variables that has N components and F is a real-valued objective function. +! It tackles the problem by a trust region method that forms quadratic models by interpolation. +! There can be some freedom in the interpolation conditions, which is taken up by minimizing the +! Frobenius norm of the change to the second derivative of the quadratic model, beginning with a +! zero matrix. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on the NEWUOA paper and Powell's code, with +! modernization, bug fixes, and improvements. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2020 +! +! Last Modified: Thursday, February 22, 2024 PM03:30:12 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: newuoa + + +contains + + +subroutine newuoa(calfun, x, & + & f, nf, rhobeg, rhoend, ftarget, maxfun, npt, iprint, eta1, eta2, gamma1, gamma2, & + & xhist, fhist, maxhist, callback_fcn, info) +!--------------------------------------------------------------------------------------------------! +! Among all the arguments, only CALFUN and X are obligatory. The others are OPTIONAL and you can +! neglect them unless you are familiar with the algorithm. Any unspecified optional input will take +! the default value detailed below. For instance, we may invoke the solver as follows. +! +! ! First define CALFUN and X, and then do the following. +! call newuoa(calfun, x, f) +! +! or +! +! ! First define CALFUN and X, and then do the following. +! call newuoa(calfun, x, f, rhobeg = 1.0D0, rhoend = 1.0D-6) +! +! See examples/newuoa_exmp.f90 for a concrete example. +! +! A detailed introduction to the arguments is as follows. +! N.B.: RP and IK are defined in the module CONSTS_MOD. See consts.F90 under the directory named +! "common". By default, RP = kind(0.0D0) and IK = kind(0), with REAL(RP) being the double-precision +! real, and INTEGER(IK) being the default integer. For ADVANCED USERS, RP and IK can be defined by +! setting PRIMA_REAL_PRECISION and PRIMA_INTEGER_KIND in common/ppf.h. Use the default if unsure. +! +! CALFUN +! Input, subroutine. +! CALFUN(X, F) should evaluate the objective function at the given REAL(RP) vector X and set the +! value to the REAL(RP) scalar F. It must be provided by the user, and its definition must conform +! to the following interface: +! !-------------------------------------------------------------------------! +! subroutine calfun(x, f) +! real(RP), intent(in) :: x(:) +! real(RP), intent(out) :: f +! end subroutine calfun +! !-------------------------------------------------------------------------! +! +! X +! Input and output, REAL(RP) vector. +! As an input, X should be an N dimensional vector that contains the starting point, N being the +! dimension of the problem. As an output, X will be set to an approximate minimizer. +! +! F +! Output, REAL(RP) scalar. +! F will be set to the objective function value of X at exit. +! +! NF +! Output, INTEGER(IK) scalar. +! NF will be set to the number of calls of CALFUN at exit. +! +! RHOBEG, RHOEND +! Inputs, REAL(RP) scalars, default: RHOBEG = 1, RHOEND = 10^-6. RHOBEG and RHOEND must be set to +! the initial and final values of a trust-region radius, both being positive and RHOEND <= RHOBEG. +! Typically RHOBEG should be about one tenth of the greatest expected change to a variable, and +! RHOEND should indicate the accuracy that is required in the final values of the variables. +! +! FTARGET +! Input, REAL(RP) scalar, default: -Inf. +! FTARGET is the target function value. The algorithm will terminate when a point with a function +! value <= FTARGET is found. +! +! MAXFUN +! Input, INTEGER(IK) scalar, default: MAXFUN_DIM_DFT*N with MAXFUN_DIM_DFT defined in the module +! CONSTS_MOD (see common/consts.F90). MAXFUN is the maximal number of calls of CALFUN. +! +! NPT +! Input, INTEGER(IK) scalar, default: 2N + 1. +! NPT is the number of interpolation conditions for each trust region model. Its value must be in +! the interval [N+2, (N+1)(N+2)/2]. +! +! IPRINT +! Input, INTEGER(IK) scalar, default: 0. +! The value of IPRINT should be set to 0, 1, -1, 2, -2, 3, or -3, which controls how much +! information will be printed during the computation: +! 0: there will be no printing; +! 1: a message will be printed to the screen at the return, showing the best vector of variables +! found and its objective function value; +! 2: in addition to 1, each new value of RHO is printed to the screen, with the best vector of +! variables so far and its objective function value; +! 3: in addition to 2, each function evaluation with its variables will be printed to the screen; +! -1, -2, -3: the same information as 1, 2, 3 will be printed, not to the screen but to a file +! named NEWUOA_output.txt; the file will be created if it does not exist; the new output will +! be appended to the end of this file if it already exists. +! Note that IPRINT = +/-3 can be costly in terms of time and/or space. +! +! ETA1, ETA2, GAMMA1, GAMMA2 +! Input, REAL(RP) scalars, default: ETA1 = 0.1, ETA2 = 0.7, GAMMA1 = 0.5, and GAMMA2 = 2. +! ETA1, ETA2, GAMMA1, and GAMMA2 are parameters in the updating scheme of the trust-region radius +! detailed in the subroutine TRRAD in trustregion.f90. Roughly speaking, the trust-region radius +! is contracted by a factor of GAMMA1 when the reduction ratio is below ETA1, and enlarged by a +! factor of GAMMA2 when the reduction ratio is above ETA2. It is required that 0 < ETA1 <= ETA2 +! < 1 and 0 < GAMMA1 < 1 < GAMMA2. Normally, ETA1 <= 0.25. It is NOT advised to set ETA1 >= 0.5. +! +! XHIST, FHIST, MAXHIST +! XHIST: Output, ALLOCATABLE rank 2 REAL(RP) array; +! FHIST: Output, ALLOCATABLE rank 1 REAL(RP) array; +! MAXHIST: Input, INTEGER(IK) scalar, default: MAXFUN +! XHIST, if present, will output the history of iterates, while FHIST, if present, will output the +! history function values. MAXHIST should be a nonnegative integer, and XHIST/FHIST will output +! only the history of the last MAXHIST iterations. Therefore, MAXHIST = 0 means XHIST/FHIST will +! output nothing, while setting MAXHIST = MAXFUN requests XHIST/FHIST to output all the history. +! If XHIST is present, its size at exit will be [N, min(NF, MAXHIST)]; if FHIST is present, its +! size at exit will be min(NF, MAXHIST). +! +! IMPORTANT NOTICE: +! Setting MAXHIST to a large value can be costly in terms of memory for large problems. +! MAXHIST will be reset to a smaller value if the memory needed exceeds MAXHISTMEM defined in +! CONSTS_MOD (see consts.F90 under the directory named "common"). +! Use *HIST with caution! (N.B.: the algorithm is NOT designed for large problems). +! +! CALLBACK_FCN +! Input, function to report progress and optionally request termination. +! +! INFO +! Output, INTEGER(IK) scalar. +! INFO is the exit flag. It will be set to one of the following values defined in the module +! INFOS_MOD (see common/infos.f90): +! SMALL_TR_RADIUS: the lower bound for the trust region radius is reached; +! FTARGET_ACHIEVED: the target function value is reached; +! MAXFUN_REACHED: the objective function has been evaluated MAXFUN times; +! MAXTR_REACHED: the trust region iteration has been performed MAXTR times (MAXTR = 2*MAXFUN); +! NAN_INF_MODEL: NaN or Inf occurs in the model; +! NAN_INF_X: NaN or Inf occurs in X. +! !--------------------------------------------------------------------------! +! The following case(s) should NEVER occur unless there is a bug. +! NAN_INF_F: the objective function returns NaN or +Inf; +! TRSUBP_FAILED: a trust region step failed to reduce the model. +! !--------------------------------------------------------------------------! +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : DEBUGGING +use, non_intrinsic :: consts_mod, only : MAXFUN_DIM_DFT +use, non_intrinsic :: consts_mod, only : RHOBEG_DFT, RHOEND_DFT, FTARGET_DFT, IPRINT_DFT +use, non_intrinsic :: consts_mod, only : RP, IK, TWO, HALF, TEN, TENTH, EPS +use, non_intrinsic :: debug_mod, only : assert, warning +use, non_intrinsic :: evaluate_mod, only : moderatex +use, non_intrinsic :: history_mod, only : prehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: memory_mod, only : safealloc +use, non_intrinsic :: pintrf_mod, only : OBJ, CALLBACK +use, non_intrinsic :: preproc_mod, only : preproc +use, non_intrinsic :: string_mod, only : num2str + +! Solver-specific modules +use, non_intrinsic :: newuob_mod, only : newuob + +implicit none + +! Compulsory arguments +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +real(RP), intent(inout) :: x(:) + +! Optional inputs +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in), optional :: iprint +integer(IK), intent(in), optional :: maxfun +integer(IK), intent(in), optional :: maxhist +integer(IK), intent(in), optional :: npt +real(RP), intent(in), optional :: eta1 +real(RP), intent(in), optional :: eta2 +real(RP), intent(in), optional :: ftarget +real(RP), intent(in), optional :: gamma1 +real(RP), intent(in), optional :: gamma2 +real(RP), intent(in), optional :: rhobeg +real(RP), intent(in), optional :: rhoend + +! Optional outputs +integer(IK), intent(out), optional :: info +integer(IK), intent(out), optional :: nf +real(RP), intent(out), optional :: f +real(RP), intent(out), optional, allocatable :: fhist(:) +real(RP), intent(out), optional, allocatable :: xhist(:, :) + +! Local variables +character(len=*), parameter :: solver = 'NEWUOA' +character(len=*), parameter :: srname = 'NEWUOA' +integer(IK) :: info_loc +integer(IK) :: iprint_loc +integer(IK) :: maxfun_loc +integer(IK) :: maxhist_loc +integer(IK) :: n +integer(IK) :: nf_loc +integer(IK) :: nhist +integer(IK) :: npt_loc +real(RP) :: eta1_loc +real(RP) :: eta2_loc +real(RP) :: f_loc +real(RP) :: ftarget_loc +real(RP) :: gamma1_loc +real(RP) :: gamma2_loc +real(RP) :: rhobeg_loc +real(RP) :: rhoend_loc +real(RP), allocatable :: fhist_loc(:) +real(RP), allocatable :: xhist_loc(:, :) + +! Sizes +n = int(size(x), kind(n)) + +! Replace any NaN in X by ZERO and Inf/-Inf in X by REALMAX/-REALMAX. +x = moderatex(x) + +! Read the inputs. + +! If RHOBEG is present, then RHOBEG_LOC is a copy of RHOBEG; otherwise, RHOBEG_LOC takes the default +! value for RHOBEG, taking the value of RHOEND into account. Note that RHOEND is considered only if +! it is present and it is VALID (i.e., finite and positive). The other inputs are read similarly. +if (present(rhobeg)) then + rhobeg_loc = rhobeg +elseif (present(rhoend)) then + ! Fortran does not take short-circuit evaluation of logic expressions. Thus it is WRONG to + ! combine the evaluation of PRESENT(RHOEND) and the evaluation of IS_FINITE(RHOEND) as + ! "IF (PRESENT(RHOEND) .AND. IS_FINITE(RHOEND))". The compiler may choose to evaluate the + ! IS_FINITE(RHOEND) even if PRESENT(RHOEND) is false! + if (is_finite(rhoend) .and. rhoend > 0) then + rhobeg_loc = max(TEN * rhoend, RHOBEG_DFT) + else + rhobeg_loc = RHOBEG_DFT + end if +else + rhobeg_loc = RHOBEG_DFT +end if + +if (present(rhoend)) then + rhoend_loc = rhoend +elseif (rhobeg_loc > 0) then + rhoend_loc = max(EPS, min((RHOEND_DFT / RHOBEG_DFT) * rhobeg_loc, RHOEND_DFT)) +else + rhoend_loc = RHOEND_DFT +end if + +if (present(ftarget)) then + ftarget_loc = ftarget +else + ftarget_loc = FTARGET_DFT +end if + +if (present(maxfun)) then + maxfun_loc = maxfun +else + maxfun_loc = MAXFUN_DIM_DFT * n +end if + +if (present(npt)) then + npt_loc = npt +elseif (maxfun_loc >= n + 3_IK) then ! Take MAXFUN into account if it is valid. + npt_loc = min(maxfun_loc - 1_IK, 2_IK * n + 1_IK) +else + npt_loc = 2_IK * n + 1_IK +end if + +if (present(iprint)) then + iprint_loc = iprint +else + iprint_loc = IPRINT_DFT +end if + +if (present(eta1)) then + eta1_loc = eta1 +elseif (present(eta2)) then + if (eta2 > 0 .and. eta2 < 1) then + eta1_loc = max(EPS, eta2 / 7.0_RP) + end if +else + eta1_loc = TENTH +end if + +if (present(eta2)) then + eta2_loc = eta2 +elseif (eta1_loc > 0 .and. eta1_loc < 1) then + eta2_loc = (eta1_loc + TWO) / 3.0_RP +else + eta2_loc = 0.7_RP +end if + +if (present(gamma1)) then + gamma1_loc = gamma1 +else + gamma1_loc = HALF +end if + +if (present(gamma2)) then + gamma2_loc = gamma2 +else + gamma2_loc = TWO +end if + +if (present(maxhist)) then + maxhist_loc = maxhist +else + maxhist_loc = maxval([maxfun_loc, n + 3_IK, MAXFUN_DIM_DFT * n]) +end if + +! Preprocess the inputs in case some of them are invalid. +call preproc(solver, n, iprint_loc, maxfun_loc, maxhist_loc, ftarget_loc, rhobeg_loc, rhoend_loc, & + & npt=npt_loc, eta1=eta1_loc, eta2=eta2_loc, gamma1=gamma1_loc, gamma2=gamma2_loc) + +! Further revise MAXHIST_LOC according to MAXHISTMEM, and allocate memory for the history. +! In MATLAB/Python/Julia/R implementation, we should simply set MAXHIST = MAXFUN and initialize +! FHIST = NaN(1, MAXFUN), XHIST = NaN(N, MAXFUN) if they are requested; replace MAXFUN with 0 for +! the history that is not requested. +call prehist(maxhist_loc, n, present(xhist), xhist_loc, present(fhist), fhist_loc) + + +!-------------------- Call NEWUOB, which performs the real calculations. --------------------------! +if (present(callback_fcn)) then + call newuob(calfun, iprint_loc, maxfun_loc, npt_loc, eta1_loc, eta2_loc, ftarget_loc, gamma1_loc, & + & gamma2_loc, rhobeg_loc, rhoend_loc, x, nf_loc, f_loc, fhist_loc, xhist_loc, info_loc, callback_fcn) +else + call newuob(calfun, iprint_loc, maxfun_loc, npt_loc, eta1_loc, eta2_loc, ftarget_loc, gamma1_loc, & + & gamma2_loc, rhobeg_loc, rhoend_loc, x, nf_loc, f_loc, fhist_loc, xhist_loc, info_loc) +end if +!--------------------------------------------------------------------------------------------------! + + +! Write the outputs. + +if (present(f)) then + f = f_loc +end if + +if (present(nf)) then + nf = nf_loc +end if + +if (present(info)) then + info = info_loc +end if + +! Copy XHIST_LOC to XHIST if needed. +if (present(xhist)) then + nhist = min(nf_loc, int(size(xhist_loc, 2), IK)) + !----------------------------------------------------! + call safealloc(xhist, n, nhist) ! Removable in F2003. + !----------------------------------------------------! + xhist = xhist_loc(:, 1:nhist) + ! N.B.: + ! 0. Allocate XHIST as long as it is present, even if the size is 0; otherwise, it will be + ! illegal to enquire XHIST after exit. + ! 1. Even though Fortran 2003 supports automatic (re)allocation of allocatable arrays upon + ! intrinsic assignment, we keep the line of SAFEALLOC, because some very new compilers (Absoft + ! Fortran 21.0) are still not standard-compliant in this respect. + ! 2. NF may not be present. Hence we should NOT use NF but NF_LOC. + ! 3. When SIZE(XHIST_LOC, 2) > NF_LOC, which is the normal case in practice, XHIST_LOC contains + ! GARBAGE in XHIST_LOC(:, NF_LOC + 1 : END). Therefore, we MUST cap XHIST at NF_LOC so that + ! XHIST contains only valid history. For this reason, there is no way to avoid allocating + ! two copies of memory for XHIST unless we declare it to be a POINTER instead of ALLOCATABLE. +end if +! F2003 automatically deallocate local ALLOCATABLE variables at exit, yet we prefer to deallocate +! them immediately when they finish their jobs. +deallocate (xhist_loc) + +! Copy FHIST_LOC to FHIST if needed. +if (present(fhist)) then + nhist = min(nf_loc, int(size(fhist_loc), IK)) + !--------------------------------------------------! + call safealloc(fhist, nhist) ! Removable in F2003. + !--------------------------------------------------! + fhist = fhist_loc(1:nhist) ! The same as XHIST, we must cap FHIST at NF_LOC. +end if +deallocate (fhist_loc) + +! If MAXFHIST_IN >= NF_LOC > MAXFHIST_LOC, warn that not all history is recorded. +if ((present(xhist) .or. present(fhist)) .and. maxhist_loc < nf_loc) then + call warning(solver, 'Only the history of the last '//num2str(maxhist_loc)//' function evaluation(s) is recorded') +end if + +! Postconditions +if (DEBUGGING) then + call assert(nf_loc <= maxfun_loc, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + nhist = min(nf_loc, maxhist_loc) + if (present(xhist)) then + call assert(size(xhist, 1) == n .and. size(xhist, 2) == nhist, 'SIZE(XHIST) == [N, NHIST]', srname) + call assert(.not. any(is_nan(xhist)), 'XHIST does not contain NaN', srname) + end if + if (present(fhist)) then + call assert(size(fhist) == nhist, 'SIZE(FHIST) == NHIST', srname) + call assert(.not. any(is_nan(fhist) .or. is_posinf(fhist)), 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(fhist < f_loc), 'F is the smallest in FHIST', srname) + end if +end if + +end subroutine newuoa + + +end module newuoa_mod diff --git a/examples/fortran/prima/native/newuoa/newuob.f90 b/examples/fortran/prima/native/newuoa/newuob.f90 new file mode 100644 index 000000000..1f96ac12d --- /dev/null +++ b/examples/fortran/prima/native/newuoa/newuob.f90 @@ -0,0 +1,693 @@ +module newuob_mod +!--------------------------------------------------------------------------------------------------! +! This module performs the major calculations of NEWUOA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the NEWUOA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2020 +! +! Last Modified: Wed 08 Apr 2026 06:38:51 PM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: newuob + + +contains + + +subroutine newuob(calfun, iprint, maxfun, npt, eta1, eta2, ftarget, gamma1, gamma2, rhobeg, & + & rhoend, x, nf, f, fhist, xhist, info, callback_fcn) +!--------------------------------------------------------------------------------------------------! +! This subroutine performs the actual calculations of NEWUOA. +! +! IPRINT, MAXFUN, MAXHIST, NPT, ETA1, ETA2, FTARGET, GAMMA1, GAMMA2, RHOBEG, RHOEND, X, NF, F, +! FHIST, XHIST, and INFO are identical to the corresponding arguments in subroutine NEWUOA. +! +! XBASE holds a shift of origin that should reduce the contributions from rounding errors to values +! of the model and Lagrange functions. +! XOPT is the displacement from XBASE of the best vector of variables so far (i.e., the one provides +! the least calculated F so far). FOPT = F(XOPT + XBASE). However, we do not save XOPT and FOPT +! explicitly, because XOPT = XPT(:, KOPT) and FOPT = FVAL(KOPT), which is explained below. +! [XPT, FVAL, KOPT] describes the interpolation set: +! XPT contains the interpolation points relative to XBASE, each COLUMN for a point; FVAL holds the +! values of F at the interpolation points; KOPT is the index of XOPT in XPT. +! [GOPT, HQ, PQ] describes the quadratic model: GOPT will hold the gradient of the quadratic model +! at XBASE+XOPT; HQ will hold the explicit second order derivatives of the quadratic model; PQ +! will contain the parameters of the implicit second order derivatives of the quadratic model. +! [BMAT, ZMAT, IDZ] describes the matrix H in the NEWUOA paper (eq. 3.12), which is the inverse of +! the coefficient matrix of the KKT system for the least-Frobenius norm interpolation problem: +! ZMAT will hold a factorization of the leading NPT*NPT submatrix of H, the factorization being +! ZMAT*Diag(DZ)*ZMAT^T with DZ(1:IDZ-1)=-1, DZ(IDZ:NPT-N-1)=1. BMAT will hold the last N ROWs of H +! except for the (NPT+1)th column. Note that the (NPT + 1)th row and column of H are not saved as +! they are unnecessary for the calculation. +! D is reserved for trial steps from XOPT. It is chosen by subroutine TRSAPP or GEOSTEP. Usually +! XBASE + XOPT + D is the vector of variables for the next call of CALFUN. +! +! See Section 2 of the NEWUOA paper for more information about these variables. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, HALF, TENTH, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: evaluate_mod, only : evaluate +use, non_intrinsic :: history_mod, only : savehist, rangehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, MAXTR_REACHED, SMALL_TR_RADIUS, CALLBACK_TERMINATE, NAN_INF_MODEL +use, non_intrinsic :: linalg_mod, only : norm +use, non_intrinsic :: message_mod, only : retmsg, rhomsg, fmsg +use, non_intrinsic :: pintrf_mod, only : OBJ, CALLBACK +use, non_intrinsic :: powalg_mod, only : quadinc, updateh +use, non_intrinsic :: ratio_mod, only : redrat +use, non_intrinsic :: redrho_mod, only : redrho +use, non_intrinsic :: shiftbase_mod, only : shiftbase + +! Solver-specific modules +use, non_intrinsic :: geometry_newuoa_mod, only : setdrop_tr, geostep +use, non_intrinsic :: initialize_newuoa_mod, only : initxf, initq, inith +use, non_intrinsic :: trustregion_newuoa_mod, only : trsapp, trrad +use, non_intrinsic :: update_newuoa_mod, only : updatexf, updateq, tryqalt + +implicit none + +! Inputs +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfun +integer(IK), intent(in) :: npt +real(RP), intent(in) :: eta1 +real(RP), intent(in) :: eta2 +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: gamma1 +real(RP), intent(in) :: gamma2 +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: rhoend + +! In-outputs +real(RP), intent(inout) :: x(:) ! X(N) + +! Outputs +integer(IK), intent(out) :: info +integer(IK), intent(out) :: nf +real(RP), intent(out) :: f +real(RP), intent(out) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out) :: xhist(:, :) ! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'NEWUOA' +character(len=*), parameter :: srname = 'NEWUOB' +integer(IK) :: idz +integer(IK) :: ij(2, max(0_IK, int(npt - 2 * size(x) - 1, IK))) +integer(IK) :: itest +integer(IK) :: k +integer(IK) :: knew_geo +integer(IK) :: knew_tr +integer(IK) :: kopt +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxtr +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: subinfo +integer(IK) :: tr +logical :: accurate_mod +logical :: adequate_geo +logical :: bad_trstep +logical :: close_itpset +logical :: improve_geo +logical :: reduce_rho +logical :: shortd +logical :: small_trrad +logical :: terminate +logical :: trfail +logical :: ximproved +real(RP) :: bmat(size(x), npt + size(x)) +real(RP) :: crvmin +real(RP) :: d(size(x)) +real(RP) :: delbar +real(RP) :: delta +real(RP) :: distsq(npt) +real(RP) :: dnorm +real(RP) :: dnorm_rec(2) ! Powell's implementation: DNORM_REC(3) +real(RP) :: fval(npt) +real(RP) :: gamma3 +real(RP) :: gopt(size(x)) +real(RP) :: hq(size(x), size(x)) +real(RP) :: moderr +real(RP) :: moderr_rec(size(dnorm_rec)) +real(RP) :: pq(npt) +real(RP) :: qred +real(RP) :: ratio +real(RP) :: rho +real(RP) :: xbase(size(x)) +real(RP) :: xdrop(size(x)) +real(RP) :: xosav(size(x)) +real(RP) :: xpt(size(x), npt) +real(RP) :: zmat(npt, npt - size(x) - 1) +real(RP), parameter :: trtol = 1.0E-2_RP ! Convergence tolerance of trust-region subproblem solver + +! Sizes +n = int(size(x), kind(n)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxhist = max(maxxhist, maxfhist) + +! Preconditions +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(maxfun >= npt + 1, 'MAXFUN >= NPT + 1', srname) + call assert(rhobeg >= rhoend .and. rhoend > 0, 'RHOBEG >= RHOEND > 0', srname) + call assert(all(is_finite(x)), 'X is finite', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + call assert(maxhist >= 0 .and. maxhist <= maxfun, '0 <= MAXHIST <= MAXFUN', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialize XBASE, XPT, FVAL, and KOPT, together with the history, NF, and IJ. +call initxf(calfun, iprint, maxfun, ftarget, rhobeg, x, ij, kopt, nf, fhist, fval, xbase, xhist, xpt, subinfo) + +! Report the current best value, and check if user asks for early termination. +terminate = .false. +if (present(callback_fcn)) then + call callback_fcn(xbase + xpt(:, kopt), fval(kopt), nf, 0_IK, terminate=terminate) + if (terminate) then + subinfo = CALLBACK_TERMINATE + end if +end if + +! Initialize X and F according to KOPT. +x = xbase + xpt(:, kopt) +f = fval(kopt) + +! Finish the initialization if INITXF completed normally and CALLBACK did not request termination; +! otherwise, do not proceed, as XPT etc may be uninitialized, leading to errors or exceptions. +if (subinfo == INFO_DFT) then + ! Initialize [BMAT, ZMAT, IDZ], representing inverse of KKT matrix of the interpolation + ! system. + call inith(ij, xpt, idz, bmat, zmat) + + ! Initialize the quadratic represented by [GOPT, HQ, PQ], so that its gradient at XBASE+XOPT is + ! GOPT; its Hessian is HQ + sum_{K=1}^NPT PQ(K)*XPT(:, K)*XPT(:, K)'. + call initq(ij, fval, xpt, gopt, hq, pq) + if (.not. (all(is_finite(gopt)) .and. all(is_finite(hq)) .and. all(is_finite(pq)))) then + subinfo = NAN_INF_MODEL + end if +end if + +! Check whether to return due to abnormal cases that may occur during the initialization. +if (subinfo /= INFO_DFT) then + info = subinfo + ! Arrange FHIST and XHIST so that they are in the chronological order. + call rangehist(nf, xhist, fhist) + ! Print a return message according to IPRINT. + call retmsg(solver, info, iprint, nf, f, x) + ! Postconditions + if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(fhist(1:min(nf, maxfhist)) < f), 'F is the smallest in FHIST', srname) + end if + return +end if + +! Set some more initial values. +! We must initialize RATIO. Otherwise, when SHORTD = TRUE, compilers may raise a run-time error that +! RATIO is undefined. But its value will not be used: when SHORTD = FALSE, its value will be +! overwritten; when SHORTD = TRUE, its value is used only in BAD_TRSTEP, which is TRUE regardless of +! RATIO. Similar for KNEW_TR. +! No need to initialize SHORTD unless MAXTR < 1, but some compilers may complain if we do not do it. +rho = rhobeg +delta = rho +shortd = .false. +trfail = .false. +ratio = -ONE +dnorm_rec = REALMAX +moderr_rec = REALMAX +knew_tr = 0 +knew_geo = 0 +itest = 0 + +! If DELTA <= GAMMA3*RHO after an update, we set DELTA to RHO. GAMMA3 must be less than GAMMA2. The +! reason is as follows. Imagine a very successful step with DENORM = the un-updated DELTA = RHO. +! Then TRRAD will update DELTA to GAMMA2*RHO. If GAMMA3 >= GAMMA2, then DELTA will be reset to RHO, +! which is not reasonable as D is very successful. See paragraph two of Sec. 5.2.5 in +! T. M. Ragonneau's thesis: "Model-Based Derivative-Free Optimization Methods and Software". +! According to test on 20230613, for NEWUOA, this Powellful updating scheme of DELTA works slightly +! better than setting directly DELTA = MAX(NEW_DELTA, RHO). +gamma3 = max(ONE, min(0.75_RP * gamma2, 1.5_RP)) + +! MAXTR is the maximal number of trust-region iterations. Here, we set it to HUGE(MAXTR) - 1 so that +! the algorithm will not terminate due to MAXTR. However, this may not be allowed in other languages +! such as MATLAB. In that case, we can set MAXTR to 10*MAXFUN, which is unlikely to reach because +! each trust-region iteration takes 1 or 2 function evaluations unless the trust-region step is short +! or fails to reduce the trust-region model but the geometry step is not invoked. +! N.B.: Do NOT set MAXTR to HUGE(MAXTR), as it may cause overflow and infinite cycling in the DO +! loop. See +! https://fortran-lang.discourse.group/t/loop-variable-reaching-integer-huge-causes-infinite-loop +! https://fortran-lang.discourse.group/t/loops-dont-behave-like-they-should +maxtr = huge(maxtr) - 1_IK !!MATLAB: maxtr = 10 * maxfun; +info = MAXTR_REACHED + +! Begin the iterative procedure. +! After solving a trust-region subproblem, we use three boolean variables to control the workflow. +! SHORTD: Is the trust-region trial step too short to invoke a function evaluation? +! IMPROVE_GEO: Should we improve the geometry (Box 8 of Fig. 1 in the NEWUOA paper)? +! REDUCE_RHO: Should we reduce rho (Boxes 14 and 10 of Fig. 1 in the NEWUOA paper)? +! NEWUOA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. +do tr = 1, maxtr + ! Generate the next trust region step D. + call trsapp(delta, gopt, hq, pq, trtol, xpt, crvmin, d) + dnorm = min(delta, norm(d)) + + ! Check whether D is too short to invoke a function evaluation. + ! SHORTD corresponds to Box 3 of the NEWUOA paper. N.B.: we compare DNORM with RHO, not DELTA. + ! HALF seems to work better than TENTH or QUART. + shortd = (dnorm <= HALF * rho) ! `<=` works better than `<` in case of underflow. + + ! Set QRED to the reduction of the quadratic model when the move D is made from XOPT. QRED + ! should be positive. If it is nonpositive due to rounding errors, we will not take this step. + qred = -quadinc(d, xpt, gopt, pq, hq) + trfail = (.not. qred > 1.0E-6 * rho**2) ! QRED is tiny/negative, or NaN. + + if (shortd .or. trfail) then + ! In this case, do nothing but reducing DELTA. Afterward, DELTA < DNORM may occur. + ! N.B.: 1. This value of DELTA will be discarded if REDUCE_RHO turns out TRUE later. + ! 2. Without shrinking DELTA, the algorithm may be stuck in an infinite cycling, because + ! both REDUCE_RHO and IMPROVE_GEO may end up with FALSE in this case. + delta = TENTH * delta + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + else + ! Calculate the next value of the objective function. + ! If X is close to one of the points in the interpolation set, then we do not evaluate the + ! objective function X, assuming it to have the value at the closest point. + x = xbase + (xpt(:, kopt) + d) + distsq = [(sum((x - (xbase + xpt(:, k)))**2, dim=1), k=1, npt)] ! Implied do-loop + !!MATLAB: distsq = sum((x - (xbase + xpt))**2, 1) % Implicit expansion + k = int(minloc(distsq, dim=1), kind(k)) + if (distsq(k) <= (1.0E-3 * rhoend)**2) then + f = fval(k) + else + ! Evaluate the objective function at X, taking care of possible Inf/NaN values. + call evaluate(calfun, x, f) + nf = nf + 1_IK + ! Save X and F into the history. + call savehist(nf, x, xhist, f, fhist) + end if + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Trust region', iprint, nf, delta, f, x) + + ! Update DNORM_REC and MODERR_REC. + ! DNORM_REC records the DNORM of the recent function evaluations with the current RHO. + dnorm_rec = [dnorm_rec(2:size(dnorm_rec)), dnorm] + ! MODERR is the error of the current model in predicting the change in F due to D. + ! MODERR_REC records the prediction errors of the recent models with the current RHO. + moderr = f - fval(kopt) + qred + moderr_rec = [moderr_rec(2:size(moderr_rec)), moderr] + + ! Calculate the reduction ratio by REDRAT, which handles Inf/NaN carefully. + ratio = redrat(fval(kopt) - f, qred, eta1) + + ! Update DELTA. After this, DELTA < DNORM may hold. + delta = trrad(delta, dnorm, eta1, eta2, gamma1, gamma2, ratio) + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + + ! Is the newly generated X better than current best point? + ximproved = (f < fval(kopt)) + + ! Set KNEW_TR to the index of the interpolation point to be replaced with XNEW = XOPT + D. + ! KNEW_TR will ensure that the geometry of XPT is "good enough" after the replacement. + ! N.B.: + ! 1. KNEW_TR = 0 means it is impossible to obtain a good interpolation set by replacing any + ! current interpolation point with XNEW. Then XNEW and its function value will be discarded. + ! In this case, the geometry of XPT likely needs improvement, which will be handled below. + ! 2. If XIMPROVED = TRUE (i.e., RATIO > 0), then SETDROP_TR should ensure KNEW_TR > 0 so that + ! XNEW is included into XPT. Otherwise, SETDROP_TR is buggy. + knew_tr = setdrop_tr(idz, kopt, ximproved, bmat, d, delta, rho, xpt, zmat) + + ! Update [BMAT, ZMAT, IDZ] (represents H in the NEWUOA paper), [XPT, FVAL, KOPT] and + ! [GOPT, HQ, PQ] (the quadratic model), so that XPT(:, KNEW_TR) becomes XNEW = XOPT + D. + ! If KNEW_TR = 0, the updating subroutines will do essentially nothing, as the algorithm + ! decides not to include XNEW into XPT. + if (knew_tr > 0) then + xdrop = xpt(:, knew_tr) + xosav = xpt(:, kopt) + call updateh(knew_tr, kopt, d, xpt, idz, bmat, zmat) + call updatexf(knew_tr, ximproved, f, xosav + d, kopt, fval, xpt) + call updateq(idz, knew_tr, ximproved, bmat, d, moderr, xdrop, xosav, xpt, zmat, gopt, hq, pq) + + ! Test whether to replace the new quadratic model Q by the least-Frobenius norm + ! interpolant Q_alt. Perform the replacement if certain criteria are satisfied. + ! N.B.: 1. This part is OPTIONAL, but it is crucial for the performance on some + ! problems. See Section 8 of the NEWUOA paper. + ! 2. TRYQALT is called only after a trust-region step but not after a geometry step, + ! maybe because the model is expected to be good after a geometry step. + ! 3. If KNEW_TR = 0 after a trust-region step, TRYQALT is not invoked. In this case, the + ! interpolation set is unchanged, so it seems reasonable to keep the model unchanged. + ! 4. In theory, FVAL - FVAL(KOPT) in the call of TRYQALT can be changed to FVAL + C with + ! any constant C. This constant will not affect the result in precise arithmetic. Powell + ! chose C = - FVAL(KOPT_OLD), where KOPT_OLD is the KOPT before the update above (Powell + ! updated KOPT after TRYQALT). Here we use C = -FVAL(KOPT), as it worked slightly better + ! on CUTEst, although there is no difference theoretically. Note that FVAL(KOPT_OLD) may + ! not equal FOPT_OLD --- it may happen that KNEW_TR = KOPT_OLD so that FVAL(KOPT_OLD) + ! has been revised after the last function evaluation. + ! 5. Powell's code tries Q_alt only when DELTA == RHO. + call tryqalt(idz, bmat, fval - fval(kopt), ratio, xpt(:, kopt), xpt, zmat, itest, gopt, hq, pq) + if (.not. (all(is_finite(gopt)) .and. all(is_finite(hq)) .and. all(is_finite(pq)))) then + info = NAN_INF_MODEL + exit + end if + end if + + ! Check whether to exit + subinfo = checkexit(maxfun, nf, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + end if ! End of IF (SHORTD .OR. TRFAIL). The normal trust-region calculation ends. + + + !----------------------------------------------------------------------------------------------! + ! Before the next trust-region iteration, we may improve the geometry of XPT or reduce RHO + ! according to IMPROVE_GEO and REDUCE_RHO, which in turn depend on the following indicators. + ! N.B.: We must ensure that the algorithm does not set IMPROVE_GEO = TRUE at infinitely many + ! consecutive iterations without moving XOPT or reducing RHO. Otherwise, the algorithm will get + ! stuck in repetitive invocations of GEOSTEP. To this end, make sure the following. + ! 1. The threshold for CLOSE_ITPSET is at least DELBAR, the trust region radius for GEOSTEP. + ! Normally, DELBAR <= DELTA <= the threshold (In Powell's UOBYQA, DELBAR = RHO < the threshold). + ! 2. If an iteration sets IMPROVE_GEO = TRUE, it must also reduce DELTA or set DELTA to RHO. + + ! ACCURATE_MOD: Are the recent models sufficiently accurate? Used only if SHORTD is TRUE. + accurate_mod = all(abs(moderr_rec) <= 0.125_RP * crvmin * rho**2) .and. all(dnorm_rec <= rho) + ! CLOSE_ITPSET: Are the interpolation points close to XOPT? It affects IMPROVE_GEO, REDUCE_RHO. + distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - xpt(:, kopt)).^2) % Implicit expansion + close_itpset = all(distsq <= 4.0_RP * delta**2) ! Powell's code. + ! Below are some alternative definitions of CLOSE_ITPSET. + ! N.B.: The threshold for CLOSE_ITPSET is at least DELBAR, the trust region radius for GEOSTEP. + ! !close_itpset = all(distsq <= 4.0_RP * rho**2) ! Powell's UOBYQA code. + ! !close_itpset = all(distsq <= max((TWO * delta)**2, (TEN * rho)**2)) ! Powell's BOBYQA code. + ! !close_itpset = all(distsq <= max(delta**2, 4.0_RP * rho**2)) ! Powell's LINCOA code. + ! ADEQUATE_GEO: Is the geometry of the interpolation set "adequate"? + adequate_geo = (shortd .and. accurate_mod) .or. close_itpset + ! SMALL_TRRAD: Is the trust-region radius small? This indicator seems not impactive in practice. + ! When MAX(DELTA, DNORM) > RHO, as Powell mentioned under (2.3) of the NEWUOA paper, "RHO has + ! not restricted the most recent choice of D", so it is not reasonable to reduce RHO. + small_trrad = (max(delta, dnorm) <= rho) ! Powell's code. + !small_trrad = (delsav <= rho) ! Behaves the same as Powell's version. DELSAV = unupdated DELTA. + + ! IMPROVE_GEO and REDUCE_RHO are defined as follows. + + ! BAD_TRSTEP (for IMPROVE_GEO): Is the last trust-region step bad? + bad_trstep = (shortd .or. trfail .or. ratio <= eta1 .or. knew_tr == 0) + improve_geo = bad_trstep .and. .not. adequate_geo + ! BAD_TRSTEP (for REDUCE_RHO): Is the last trust-region step bad? + bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) + reduce_rho = bad_trstep .and. adequate_geo .and. small_trrad + + ! Equivalently, REDUCE_RHO can be set as follows. It shows that REDUCE_RHO is TRUE in two cases. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) + ! !reduce_rho = (shortd .and. accurate_mod) .or. (bad_trstep .and. close_itpset .and. small_trrad) + + ! With REDUCE_RHO properly defined, we can also set IMPROVE_GEO as follows. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= eta1 .or. knew_tr == 0) + ! !improve_geo = bad_trstep .and. (.not. reduce_rho) .and. (.not. close_itpset) + + ! With IMPROVE_GEO properly defined, we can also set REDUCE_RHO as follows. + ! !bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) + ! !reduce_rho = bad_trstep .and. (.not. improve_geo) .and. small_trrad + + ! NEWUOA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. + !call assert(.not. (improve_geo .and. reduce_rho), 'IMPROVE_GEO and REDUCE_RHO are not both TRUE', srname) + ! + ! If SHORTD or TRFAIL is TRUE, then either IMPROVE_GEO or REDUCE_RHO is TRUE unless CLOSE_ITPSET + ! is TRUE but SMALL_TRRAD is FALSE. + !call assert((.not. (shortd .or. trfail)) .or. (improve_geo .or. reduce_rho .or. & + ! & (close_itpset .and. .not. small_trrad)), 'If SHORTD or TRFAIL is TRUE, then either & + ! & IMPROVE_GEO or REDUCE_RHO is TRUE unless CLOSE_ITPSET is TRUE but SMALL_TRRAD is FALSE', srname) + !----------------------------------------------------------------------------------------------! + + ! Comments on REDUCE_RHO: + ! REDUCE_RHO corresponds to Boxes 14 and 10 of the NEWUOA paper. + ! There are two case where REDUCE_RHO will be set to TRUE. + ! Case 1. The trust-region step is short (SHORTD) and all the recent models are sufficiently + ! accurate (ACCURATE_MOD), which corresponds to Box 14 of the NEWUOA paper. Why do we reduce RHO + ! in this case? The reason is well explained by the BOBYQA paper around (6.9)--(6.10). Roughly + ! speaking, in this case, a trust-region step is unlikely to decrease the objective function + ! according to some estimations. This suggests that the current trust-region center may be an + ! approximate local minimizer. When this occurs, the algorithm takes the view that the work for + ! the current RHO is complete, and hence it will reduce RHO, which will enhance the resolution + ! of the algorithm in general. The penultimate paragraph of Sec. 2 of the NEWUOA explains why + ! this strategy is important to efficiency: without this strategy, each value of RHO typically + ! consumes at least NPT - 1 function evaluations, which is laborious when NPT is (modestly) big. + ! Case 2. All the interpolation points are close to XOPT (CLOSE_ITPSET) and the trust region is + ! small (SMALL_TRRAD), but the trust-region step is "bad" (SHORTD is TRUE or RATIO is small). In + ! this case, the algorithm decides that the work corresponding to the current RHO is complete, + ! and hence it shrinks RHO (i.e., update the criterion for the "closeness" and SHORTD). Surely, + ! one may ask whether this is the best choice --- it may happen that the trust-region step is + ! bad because the trust-region model is poor. NEWUOA takes the view that, if XPT contains points + ! far away from XOPT, the model can be substantially improved by replacing the farthest point + ! with a nearby one produced by the geometry step; otherwise, it does not try the geometry step. + ! N.B.: + ! 0. If SHORTD is TRUE at the very first iteration, then REDUCE_RHO will be set to TRUE. + ! 1. DELTA has been updated before arriving here: if SHORTD = TRUE, then DELTA was reduced by a + ! factor of 10; otherwise, DELTA was updated after the trust-region iteration. DELTA < DNORM may + ! hold due to the update of DELTA. + ! 2. If SHORTD = FALSE and KNEW_TR > 0, then XPT has been updated after the trust-region + ! iteration; if RATIO > 0 in addition, then XOPT has been updated as well. + ! 3. If SHORTD = TRUE and REDUCE_RHO = TRUE, the trust-region step D does not invoke a function + ! evaluation at the current iteration, but the same D will be generated again at the next + ! iteration after RHO is reduced and DELTA is updated. See the end of Sec 2 of the NEWUOA paper. + ! 4. If SHORTD = FALSE and KNEW_TR = 0, then the trust-region step invokes a function evaluation + ! at XOPT + D, but [XOPT + D, F(XOPT +D)] is not included into [XPT, FVAL]. In other words, this + ! function value is discarded. + ! 5. If SHORTD = FALSE, KNEW_TR > 0 and RATIO <= TENTH, then [XPT, FVAL] is updated so that + ! [XPT(KNEW_TR), FVAL(KNEW_TR)] = [XOPT + D, F(XOPT + D)], and the model is updated accordingly, + ! but such a model will not be used in the next trust-region iteration, because a geometry step + ! will be invoked to improve the geometry of the interpolation set and update the model again. + ! 6. RATIO must be set even if SHORTD = TRUE. Otherwise, compilers will raise a run-time error. + ! 7. We can move this setting of REDUCE_RHO downward below the definition of IMPROVE_GEO and + ! change it to REDUCE_RHO = BAD_TRSTEP .AND. (.NOT. IMPROVE_GEO) .AND. (MAX(DELTA,DNORM) <= RHO) + ! This definition can even be moved below IF (IMPROVE_GEO) ... END IF. Although DNORM gets a new + ! value after the geometry step when IMPROVE_GEO = TRUE, this value does not affect REDUCE_RHO, + ! because DNORM comes into play only if IMPROVE_GEO = FALSE. + + ! Comments on IMPROVE_GEO: + ! IMPROVE_GEO corresponds to Box 8 of the NEWUOA paper. + ! The geometry of XPT likely needs improvement if the trust-region step is bad (SHORTD or RATIO + ! is small). As mentioned above, NEWUOA tries improving the geometry only if some points in XPT + ! are far away from XOPT. In addition, if the work for the current RHO is complete, then NEWUOA + ! reduces RHO instead of improving the geometry of XPT. Particularly, if REDUCE_RHO is true + ! according to Box 14 of the NEWUOA paper (D is short, and the recent models are sufficiently + ! accurate), then "trying to improve the accuracy of the model would be a waste of effort" + ! (see Powell's comment above (7.7) of the NEWUOA paper). + + ! Comments on BAD_TRSTEP: + ! 0. KNEW_TR == 0 means that it is impossible to obtain a good XPT by replacing a current point + ! with the one suggested by the trust-region step. According to SETDROP_TR, KNEW_TR is 0 only if + ! RATIO <= 0. Therefore, we can remove KNEW_TR == 0 from the definitions of BAD_TRSTEP. + ! Nevertheless, we keep it for robustness. Powell's code includes this condition as well. + ! 1. Powell used different thresholds (0 and 0.1) for RATIO in the definitions of BAD_TRSTEP + ! above. Unifying them to 0 makes little difference to the performance, sometimes worsening, + ! sometimes improving, never substantially; unifying them to 0.1 makes little difference either. + ! Update 20220204: In the current version, unifying the two thresholds to 0 seems to worsen + ! the performance on noise-free CUTEst problems with at most 200 variables; unifying them to 0.1 + ! worsens it a bit as well. + ! 2. Powell's code does not have TRFAIL in BAD_TRSTEP; it terminates if TRFAIL is TRUE. + ! 3. Update 20221108: In UOBYQA, the definition of BAD_TRSTEP involves DDMOVE, which is the norm + ! square of XPT_OLD(:, KNEW_TR) - XOPT_OLD, where XPT_OLD and XOPT_OLD are the XPT and XOPT + ! before UPDATEXF is called. Roughly speaking, BAD_TRSTEP is set to FALSE if KNEW_TR > 0 and + ! DDMOVE > 2*RHO. This is critical for the performance of UOBYQA. However, the same strategy + ! does not improve the performance of NEWUOA/BOBYQA/LINCOA in a test on 20221108/9. + + + ! Since IMPROVE_GEO and REDUCE_RHO are never TRUE simultaneously, the following two blocks are + ! exchangeable: IF (IMPROVE_GEO) ... END IF and IF (REDUCE_RHO) ... END IF. + + ! Improve the geometry of the interpolation set by removing a point and adding a new one. + if (improve_geo) then + ! XPT(:, KNEW_GEO) will become XOPT + D below. KNEW_GEO /= KOPT unless there is a bug. + knew_geo = int(maxloc(distsq, dim=1), kind(knew_geo)) + + ! Set DELBAR, which will be used as the trust-region radius for the geometry-improving + ! scheme GEOSTEP. Note that DELTA has been updated before arriving here. See the comments + ! above the definition of IMPROVE_GEO. + delbar = max(min(TENTH * sqrt(maxval(distsq)), HALF * delta), rho) ! Powell's code + !delbar = rho ! Powell's UOBYQA code + !delbar = max(TENTH * delta, rho) ! Powell's LINCOA code + !delbar = max(min(TENTH * sqrt(maxval(distsq)), delta), rho) ! Powell's BOBYQA code + + ! Find D so that the geometry of XPT will be improved when XPT(:, KNEW_GEO) becomes XOPT + D. + ! The GEOSTEP subroutine will call Powell's BIGLAG and BIGDEN. + d = geostep(idz, knew_geo, kopt, bmat, delbar, xpt, zmat) + + ! Calculate the next value of the objective function. + ! If X is close to one of the points in the interpolation set, then we do not evaluate the + ! objective function X, assuming it to have the value at the closest point. + x = xbase + (xpt(:, kopt) + d) + distsq = [(sum((x - (xbase + xpt(:, k)))**2, dim=1), k=1, npt)] ! Implied do-loop + !!MATLAB: distsq = sum((x - (xbase + xpt))**2, 1) % Implicit expansion + k = int(minloc(distsq, dim=1), kind(k)) + if (distsq(k) <= (1.0E-3 * rhoend)**2) then + f = fval(k) + else + ! Evaluate the objective function at X, taking care of possible Inf/NaN values. + call evaluate(calfun, x, f) + nf = nf + 1_IK + ! Save X and F into the history. + call savehist(nf, x, xhist, f, fhist) + end if + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Geometry', iprint, nf, delbar, f, x) + + ! Update DNORM_REC and MODERR_REC. (Should we?) + ! DNORM_REC contains the DNORM of the recent function evaluations with the current RHO. + dnorm = min(delbar, norm(d)) ! In theory, DNORM = DELBAR in this case. + dnorm_rec = [dnorm_rec(2:size(dnorm_rec)), dnorm] + + ! MODERR is the error of the current model in predicting the change in F due to D. + ! MODERR_REC is the prediction errors of the recent models with the current RHO. + moderr = f - fval(kopt) - quadinc(d, xpt, gopt, pq, hq) + moderr_rec = [moderr_rec(2:size(moderr_rec)), moderr] + !------------------------------------------------------------------------------------------! + ! Zaikun 20200801: Powell's code does not update DNORM. Therefore, DNORM is the length of + ! the last trust-region trial step, which seems inconsistent with what is described in + ! Section 7 (around (7.7)) of the NEWUOA paper. Seemingly we should keep DNORM = ||D|| + ! as we do here. The same problem exists in BOBYQA. + !------------------------------------------------------------------------------------------! + + ! Is the newly generated X better than current best point? + ximproved = (f < fval(kopt)) + + ! Update [BMAT, ZMAT, IDZ] (represents H in the NEWUOA paper), [XPT, FVAL, KOPT] and + ! [GOPT, HQ, PQ] (the quadratic model), so that XPT(:, KNEW_GEO) becomes XNEW = XOPT + D. + xdrop = xpt(:, knew_geo) + xosav = xpt(:, kopt) + call updateh(knew_geo, kopt, d, xpt, idz, bmat, zmat) + call updatexf(knew_geo, ximproved, f, xosav + d, kopt, fval, xpt) + call updateq(idz, knew_geo, ximproved, bmat, d, moderr, xdrop, xosav, xpt, zmat, gopt, hq, pq) + if (.not. (all(is_finite(gopt)) .and. all(is_finite(hq)) .and. all(is_finite(pq)))) then + info = NAN_INF_MODEL + exit + end if + + ! Check whether to exit + subinfo = checkexit(maxfun, nf, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + end if ! End of IF (IMPROVE_GEO). The procedure of improving geometry ends. + + ! The calculations with the current RHO are complete. Enhance the resolution of the algorithm + ! by reducing RHO; update DELTA at the same time. + if (reduce_rho) then + if (rho <= rhoend) then + info = SMALL_TR_RADIUS + exit + end if + delta = max(HALF * rho, redrho(rho, rhoend)) + rho = redrho(rho, rhoend) + ! Print a message about the reduction of RHO according to IPRINT. + call rhomsg(solver, iprint, nf, delta, fval(kopt), rho, xbase + xpt(:, kopt)) + ! DNORM_REC and MODERR_REC are corresponding to the recent function evaluations with + ! the current RHO. Update them after reducing RHO. + dnorm_rec = REALMAX + moderr_rec = REALMAX + end if ! End of IF (REDUCE_RHO). The procedure of reducing RHO ends. + + ! Shift XBASE if XOPT may be too far from XBASE. + ! Powell's original criteria for shifting XBASE is as follows. + ! 1. After a trust region step that is not short, shift XBASE if SUM(XOPT**2) >= 1.0E3*DNORM**2. + ! 2. Before a geometry step, shift XBASE if SUM(XOPT**2) >= 1.0E3*DELBAR**2. + ! 3. 1.0E2 works better than 1.0E3 on 20230227. In addition, 1.0E2 works better than 2.0E2, + ! 5.0E2, and 1.0E3 on 20240406, especially if RP = REAL32. + if (sum(xpt(:, kopt)**2) >= 1.0E2_RP * delta**2) then + call shiftbase(kopt, xbase, xpt, zmat, bmat, pq, hq, idz) + end if + + ! Report the current best value, and check if user asks for early termination. + if (present(callback_fcn)) then + call callback_fcn(xbase + xpt(:, kopt), fval(kopt), nf, tr, terminate=terminate) + if (terminate) then + info = CALLBACK_TERMINATE + exit + end if + end if + +end do ! End of DO TR = 1, MAXTR. The iterative procedure ends. + +! Return from the calculation, after trying the Newton-Raphson step if it has not been tried yet. +x = xbase + (xpt(:, kopt) + d) +if (info == SMALL_TR_RADIUS .and. shortd .and. norm(x - (xbase + xpt(:, kopt))) > TENTH * rhoend .and. nf < maxfun) then + call evaluate(calfun, x, f) + nf = nf + 1_IK + ! Save X, F into the history. + call savehist(nf, x, xhist, f, fhist) + ! Print a message about the function evaluation according to IPRINT. + ! Zaikun 20230512: DELTA has been updated. RHO is only indicative here. TO BE IMPROVED. + call fmsg(solver, 'Trust region', iprint, nf, rho, f, x) + if (f < fval(kopt)) then + xpt(:, kopt) = xpt(:, kopt) + d + fval(kopt) = f + end if +end if + +! Choose the [X, F] to return. +x = xbase + xpt(:, kopt) +f = fval(kopt) + +! Arrange FHIST and XHIST so that they are in the chronological order. +call rangehist(nf, xhist, fhist) + +! Print a return message according to IPRINT. +call retmsg(solver, info, iprint, nf, f, x) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(fhist(1:min(nf, maxfhist)) < f), 'F is the smallest in FHIST', srname) +end if + +end subroutine newuob + + +end module newuob_mod diff --git a/examples/fortran/prima/native/newuoa/trustregion.f90 b/examples/fortran/prima/native/newuoa/trustregion.f90 new file mode 100644 index 000000000..d7623287c --- /dev/null +++ b/examples/fortran/prima/native/newuoa/trustregion.f90 @@ -0,0 +1,555 @@ +module trustregion_newuoa_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning the trust-region calculations of NEWUOA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the NEWUOA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2020 +! +! Last Modified: Saturday, April 06, 2024 PM11:03:07 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: trsapp, trrad + +contains + + +subroutine trsapp(delta, gopt_in, hq_in, pq_in, tol, xpt, crvmin, s, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine finds an approximate solution to the N-dimensional trust region subproblem +! +! min + 0.5* s.t. ||S|| <= DELTA +! +! Note that the HESSIAN here is the sum of an explicit part HQ and an implicit part (PQ, XPT): +! +! HESSIAN = HQ + sum_K=1^NPT PQ(K)*XPT(:, K)*XPT(:, K)' . +! +! The calculation of S begins with the truncated conjugate gradient method. If the boundary of the +! trust region is reached, then further changes to S may be made, each one being in the 2-dimensional +! space spanned by the current S and the corresponding gradient of Q. Thus S should provide a +! substantial reduction to Q within the trust region. See Section 5 of the NEWUOA paper. +! +! At return, S will be the approximate solution. CRVMIN will be set to the least curvature of +! HESSIAN along the conjugate directions that occur, except that it is set to ZERO if S goes all the +! way to the trust-region boundary. INFO is an exit flag with the following possible values. +! - INFO = 0: an approximate solution satisfying one of the following conditions is found: +! 1. ||G+HS||/||G0|| <= TOL, +! 2. ||S|| = DELTA and >= (1 - TOL)*||S||*||G+HS||, +! where TOL is set to 1e-2 in NEWUOA; +! - INFO = 1: the last iteration reduces Q only insignificantly; +! - INFO = 2: the maximal number of iterations is attained; +! - INFO = -1: too much rounding error to continue. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, TWO, HALF, REALMIN, ZERO, TENTH, EPS, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : inprod, issymmetric, norm, project +use, non_intrinsic :: powalg_mod, only : hess_mul +use, non_intrinsic :: univar_mod, only : circle_min + +implicit none + +! Inputs +real(RP), intent(in) :: delta +real(RP), intent(in) :: gopt_in(:) ! GOPT_IN(N) +real(RP), intent(in) :: hq_in(:, :) ! HQ_IN(N, N) +real(RP), intent(in) :: pq_in(:) ! PQ_IN(NPT) +real(RP), intent(in) :: tol +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +real(RP), intent(out) :: crvmin +real(RP), intent(out) :: s(:) ! S(N) +integer(IK), intent(out), optional :: info + +! Local variables +character(len=*), parameter :: srname = 'TRSAPP' +integer(IK) :: info_loc +integer(IK) :: iter +integer(IK) :: maxiter +integer(IK) :: n +integer(IK) :: npt +logical :: scaled +logical :: twod_search +real(RP) :: alpha +real(RP) :: angle +real(RP) :: args(4) +real(RP) :: bstep +real(RP) :: cth +real(RP) :: d(size(gopt_in)) +real(RP) :: dd +real(RP) :: delsq +real(RP) :: dg +real(RP) :: dhd +real(RP) :: dhs +real(RP) :: ds +real(RP) :: g(size(gopt_in)) +real(RP) :: gg +real(RP) :: gg0 +real(RP) :: ggsav +real(RP) :: gopt(size(gopt_in)) +real(RP) :: hd(size(gopt_in)) +real(RP) :: hq(size(hq_in, 1), size(hq_in, 2)) +real(RP) :: hs(size(gopt_in)) +real(RP) :: modscal +real(RP) :: pq(size(pq_in)) +real(RP) :: qadd +real(RP) :: qred +real(RP) :: reduc +real(RP) :: resid +real(RP) :: sg +real(RP) :: shs +real(RP) :: sold(size(gopt_in)) +real(RP) :: sqrtd +real(RP) :: ss +real(RP) :: sth + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(delta > 0, 'DELTA > 0', srname) + call assert(size(gopt_in) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq_in, 1) == n .and. issymmetric(hq_in), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq_in) == npt, 'SIZE(PQ) = NPT', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(s) == n, 'SIZE(S) == N', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Scale the problem if GOPT contains large values. Otherwise, floating point exceptions may occur. +! Note that CRVMIN must be scaled back if it is nonzero, but the step is scale invariant. +! N.B.: It is faster and safer to scale by multiplying a reciprocal than by division. See +! https://fortran-lang.discourse.group/t/ifort-ifort-2021-8-0-1-0e-37-1-0e-38-0/ +if (maxval(abs(gopt_in)) > 1.0E12) then ! The threshold is empirical. + modscal = max(TWO * REALMIN, ONE / maxval(abs(gopt_in))) ! MAX: precaution against underflow. + gopt = gopt_in * modscal + pq = pq_in * modscal + hq = hq_in * modscal + scaled = .true. +else + modscal = ONE ! This value is not used, but Fortran compilers may complain without it. + gopt = gopt_in + pq = pq_in + hq = hq_in + scaled = .false. +end if + +s = ZERO +crvmin = ZERO +qred = ZERO +info_loc = 2 ! Default exit flag is 2, i.e., MAXITER is attained + +! Prepare for the first line search. +!--------------------------------------------------------------------------------------------------! +! N.B.: During the iterations, G is NOT updated, and it equals always GOPT, which is the gradient +! of the trust-region model at the trust-region center X. However, GG is updated: GG = ||G + HS||^2, +! which is the norm square of the gradient at the current iterate. +g = gopt +gg = inprod(g, g) +!--------------------------------------------------------------------------------------------------! +gg0 = gg +d = -g +dd = gg +ds = ZERO +ss = ZERO +hs = ZERO +delsq = delta * delta +maxiter = n + +twod_search = .false. + +! The truncated-CG iterations. +! +! The iteration will be terminated in 4 possible cases: +! 1. the maximal number of iterations is attained; +! 2. QADD <= TOL*QRED or ||G|| <= TOL*||G0||, where QADD is the reduction of Q due to the latest +! CG step, QRED is the reduction of Q since the beginning until the latest CG step, G is the +! current gradient, and G0 is the initial gradient; see (5.13) of the NEWUOA paper; +! 3. DS <= 0 +! 4. ||S|| = DELTA, i.e., CG path cuts the trust region boundary. +! +! In the 4th case, twod_search will be set to true, meaning that S will be improved by a sequence of +! two-dimensional search, the two-dimensional subspace at each iteration being span(S, -G). +do iter = 1, maxiter + ! Exit if G contains NaN. + if (is_nan(gg)) then + info_loc = -1 + exit + end if + ! Exit if GG is small. This must be done first; otherwise, DD can be 0 and BSTEP is not well + ! defined. The inequality below must be non-strict so that GG = GG0 = 0 will trigger the exit. + if (gg <= (tol**2) * gg0) then + info_loc = 0 + exit + end if + + ! Set BSTEP to the step length such that ||S + BSTEP*D|| = DELTA. + if (iter == 1) then + bstep = delta / sqrt(dd) + else + resid = delsq - ss + if (resid <= 0) then + twod_search = .true. + exit + end if + + ! Powell's code does not have the following two IFs. + !--------------------------------------------------! + if (dd <= EPS * delsq) then + info_loc = 0 + exit + end if + if (is_nan(ds)) then + info_loc = -1 + exit + end if + !--------------------------------------------------! + + ! SQRTD: square root of a discriminant. The MAXVAL avoids SQRTD < ABS(DS) due to underflow. + sqrtd = maxval([sqrt(ds**2 + dd * resid), abs(ds), sqrt(dd * resid)]) + ! Powell's code does not distinguish the following two cases, which have no difference in + ! precise arithmetic. The following scheme stabilizes the calculation. Copied from LINCOA. + if (ds <= 0) then + bstep = (sqrtd - ds) / dd + else + bstep = resid / (sqrtd + ds) + end if + end if + + ! BSTEP < 0 should not happen. BSTEP may be 0 or NaN if, e.g., DS or DD becomes Inf. + if (bstep <= 0) then + exit + end if + if (.not. is_finite(bstep)) then + info_loc = -1 + exit + end if + + hd = hess_mul(d, xpt, pq, hq) + dhd = inprod(d, hd) + + ! Set the step-length ALPHA and update CRVMIN. + if (dhd <= 0) then + alpha = bstep + else + alpha = min(bstep, gg / dhd) + if (iter == 1) then + crvmin = dhd / dd + else + crvmin = min(crvmin, dhd / dd) + end if + end if + ! QADD is the reduction of Q due to the new CG step. + qadd = alpha * (gg - HALF * alpha * dhd) + ! QRED is the reduction of Q up to now. + qred = qred + qadd + ! QADD and QRED will be used in the 2-dimensional minimization if any. + + ! Update S, HS, and GG. + sold = s + s = s + alpha * d + ss = inprod(s, s) + hs = hs + alpha * hd + ggsav = gg ! Gradient norm square before this iteration + gg = inprod(g + hs, g + hs) ! Current gradient norm square + ! We may record g+hs for later usage: + ! gnew = g + hs + ! Note that we should NOT set g = g + hs, because g contains the gradient of Q at X. + + ! Check whether to exit. This should be done after updating HS and GG, which will be used for + ! the 2-dimensional minimization if any. + ! Exit in case of Inf/NaN in S. This should come the first! Otherwise, we may return an S that + ! contains NaN and fulfills other exit conditions. + if (.not. is_finite(sum(abs(s)))) then + s = sold + info_loc = -1 + exit + end if + + ! Exit if CG path cuts the boundary. It is the only possibility that TWOD_SEARCH is true. + if (alpha >= bstep .or. ss >= delsq) then + crvmin = ZERO + twod_search = (n >= 2 .and. gg > (tol**2) * gg0) ! TWOD_SEARCH should be FALSE if N = 1. + exit + end if + + ! Exit due to small QADD. + if (qadd <= tol * qred) then + info_loc = 1 + exit + end if + + ! Prepare for the next CG iteration. + d = (gg / ggsav) * d - g - hs ! CG direction + dd = inprod(d, d) + ds = inprod(d, s) + if (ds <= 0) then + ! DS is positive in theory. + info_loc = -1 + exit + end if +end do + +if (ss <= 0 .or. is_nan(ss)) then + ! This may occur for ill-conditioned problems due to rounding. + info_loc = -1 + twod_search = .false. +end if + +if (twod_search) then + ! At least 1 iteration of 2-dimensional minimization + maxiter = max(1_IK, maxiter - iter) +else + maxiter = 0 +end if + +! The 2-dimensional minimization +! N.B.: During the iterations, G is NOT updated, and it equals always GOPT, which is the gradient +! of the trust-region model at the trust-region center X. However, GG is updated: GG = ||G + HS||^2, +! which is the norm square of the gradient at the current iterate. +do iter = 1, maxiter + ! Exit if G contains NaN. + if (is_nan(gg)) then + info_loc = -1 + exit + end if + ! Exit if GG is small. The inequality must be non-strict so that GG = GG0 = 0 triggers the exit. + if (gg <= (tol**2) * gg0) then + info_loc = 0 + exit + end if + sg = inprod(s, g) + shs = inprod(s, hs) + + ! Begin the 2-dimensional minimization by calculating D and HD and some scalar products. + + ! Powell's code calculates D as follows. In precise arithmetic, INPROD(D, S) = 0, ||D|| = ||S||. + ! However, when DELSQ*GG - SGK**2 is tiny, the error in D can be large and hence damage these + ! equalities significantly. This did happen in tests, especially when using the single precision. + ! !sgk = sg + shs + ! !if (sgk / sqrt(gg * delsq) <= tol - ONE) then + ! ! info_loc = 0 + ! ! exit + ! !end if + ! !t = sqrt(delsq * gg - sgk**2) + ! !d = (delsq / t) * (g + hs) - (sgk / t) * s + + ! We calculate D as below. It did improve the performance of NEWUOA in our test. + ! PROJECT(X, V) returns the projection of X to SPAN(V): X'*(V/||V||)*(V/||V||). + d = (g + hs) - project(g + hs, s) + ! N.B.: + ! 1. The condition ||D||<=SQRT(TOL*GG) below is equivalent to |INPROD(G+HS,S)|<=SQRT((1-TOL)*GG*SS). + ! As given above, Powell's code triggers an exit if INPROD(G+HS,S)=SGK<=(TOL-1)*SQRT(GG*SS). + ! Since |SQRT(1-TOL) - (1-TOL)| <= TOL/2, our condition is close to |SGK| <= (TOL-1)*GG*SS. + ! When |SGK| is tiny, S and G+HS are nearly parallel and hence the 2-dimensional search cannot + ! continue. Note that SGK is unlikely positive if everything goes well. + ! 2. SQRT(TOL)*SQRT(GG) is less likely to encounter underflow than SQRT(TOL*GG). + ! 3. The condition below should be non-strict so that ||D|| = 0 can trigger the exit. + if (norm(d) <= sqrt(tol) * sqrt(gg)) then + info_loc = 0 + exit + end if + d = (norm(s) / norm(d)) * d + ! In precise arithmetic, INPROD(D, S) = 0 and ||D|| = ||S|| = DELTA. + if (abs(inprod(d, s)) >= TENTH * norm(d) * norm(s) .or. norm(d) >= TWO * delta) then + info_loc = -1 + exit + end if + + hd = hess_mul(d, xpt, pq, hq) + + ! Seek the value of the angle that minimizes Q. + ! First, calculate the coefficients of the objective function on the circle. + dg = inprod(d, g) + dhd = inprod(hd, d) + dhs = inprod(hd, s) + args = [sg, HALF * (shs - dhd), dg, dhs] + ! The 50 in the line below was chosen by Powell. It works the best in tests, MAGICALLY. Larger + ! (e.g., 60, 100) or smaller (e.g., 20, 40) values will worsen the performance of NEWUOA. Why?? + angle = circle_min(circle_fun_trsapp, args, 50_IK) + + ! Calculate the new S. + cth = cos(angle) + sth = sin(angle) + sold = s + s = cth * s + sth * d + + ! Exit in case of Inf/NaN in S. + if (.not. is_finite(sum(abs(s)))) then + s = sold + info_loc = -1 + exit + end if + + ! Test for convergence. + reduc = circle_fun_trsapp(ZERO, args) - circle_fun_trsapp(angle, args) + qred = qred + reduc + if (reduc / qred <= tol) then + info_loc = 1 + exit + end if + + ! Calculate HS. + hs = cth * hs + sth * hd + gg = inprod(g + hs, g + hs) +end do + +! Set CRVMIN to zero if it is NaN, which may happen if the problem is ill-conditioned. +if (is_nan(crvmin)) then + crvmin = ZERO +end if + +! Scale CRVMIN back before return. Note that the trust-region step is scale invariant. +if (scaled .and. crvmin > 0) then + crvmin = crvmin / modscal +end if + +if (present(info)) then + info = info_loc +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(s) == n .and. all(is_finite(s)), 'SIZE(S) == N, S is finite', srname) + ! Due to rounding, it may happen that ||S|| > DELTA, but ||S|| > 2*DELTA is highly improbable. + call assert(norm(s) <= TWO * delta, '||S|| <= 2*DELTA', srname) + call assert(crvmin >= 0, 'CRVMIN >= 0', srname) +end if + +end subroutine trsapp + + +function circle_fun_trsapp(theta, args) result(f) +!--------------------------------------------------------------------------------------------------! +! This function defines the objective function of the 2-dimensional search on a circle in TRSAPP. +!--------------------------------------------------------------------------------------------------! +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +implicit none +! Inputs +real(RP), intent(in) :: theta +real(RP), intent(in) :: args(:) + +! Outputs +real(RP) :: f + +! Local variables +character(len=*), parameter :: srname = 'CIRCLE_FUN_TRSAPP' +real(RP) :: cth +real(RP) :: sth + +! Preconditions +if (DEBUGGING) then + call assert(size(args) == 4, 'SIZE(ARGS) == 4', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +cth = cos(theta) +sth = sin(theta) +f = (args(1) + args(2) * cth) * cth + (args(3) + args(4) * cth) * sth + +!====================! +! Calculation ends ! +!====================! +end function circle_fun_trsapp + + +function trrad(delta_in, dnorm, eta1, eta2, gamma1, gamma2, ratio) result(delta) +!--------------------------------------------------------------------------------------------------! +! This function updates the trust region radius according to RATIO and DNORM. +!--------------------------------------------------------------------------------------------------! + +! Generic module +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan +use, non_intrinsic :: debug_mod, only : assert + +implicit none + +! Input +real(RP), intent(in) :: delta_in ! Current trust-region radius +real(RP), intent(in) :: dnorm ! Norm of current trust-region step +real(RP), intent(in) :: eta1 ! Ratio threshold for contraction +real(RP), intent(in) :: eta2 ! Ratio threshold for expansion +real(RP), intent(in) :: gamma1 ! Contraction factor +real(RP), intent(in) :: gamma2 ! Expansion factor +real(RP), intent(in) :: ratio ! Reduction ratio + +! Outputs +real(RP) :: delta + +! Local variables +character(len=*), parameter :: srname = 'TRRAD' + +! Preconditions +if (DEBUGGING) then + call assert(delta_in >= dnorm .and. dnorm > 0, 'DELTA_IN >= DNORM > 0', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + ! By the definition of RATIO in ratio.f90, RATIO cannot be NaN unless the actual reduction is + ! NaN, which should NOT happen due to the moderated extreme barrier. + call assert(.not. is_nan(ratio), 'RATIO is not NaN', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (ratio <= eta1) then + delta = gamma1 * dnorm ! Powell's UOBYQA/NEWUOA. + !delta = gamma1 * delta_in ! Powell's COBYLA/LINCOA. Works poorly here. + !delta = min(gamma1 * delta_in, dnorm) ! Powell's BOBYQA. +elseif (ratio <= eta2) then + delta = max(gamma1 * delta_in, dnorm) ! Powell's UOBYQA/NEWUOA/BOBYQA/LINCOA +else + delta = max(gamma1 * delta_in, gamma2 * dnorm) ! Powell's NEWUOA/BOBYQA. + !delta = max(delta_in, gamma2 * dnorm) ! Modified version. Works well for UOBYQA. + ! For noise-free CUTEst problems of <= 200 variables, Powell's version works slightly better + ! than the modified one. + !delta = max(delta_in, 1.25_RP * dnorm, dnorm + rho) ! Powell's UOBYQA + !delta = min(max(gamma1 * delta_in, gamma2 * dnorm), sqrt(gamma2) * delta_in) ! Powell's LINCOA. +end if + +! For noisy problems, the following may work better. +! !if (ratio <= eta1) then +! ! delta = gamma1 * dnorm +! !elseif (ratio <= eta2) then ! Ensure DELTA >= DELTA_IN +! ! delta = delta_in +! !else ! Ensure DELTA > DELTA_IN with a constant factor +! ! delta = max(delta_in * (1.0_RP + gamma2) / 2.0_RP, gamma2 * dnorm) +! !end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(delta > 0, 'DELTA > 0', srname) +end if + +end function trrad + + +end module trustregion_newuoa_mod diff --git a/examples/fortran/prima/native/newuoa/update.f90 b/examples/fortran/prima/native/newuoa/update.f90 new file mode 100644 index 000000000..01bac03aa --- /dev/null +++ b/examples/fortran/prima/native/newuoa/update.f90 @@ -0,0 +1,316 @@ +module update_newuoa_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning the updates when XPT(:, KNEW) becomes XNEW = XOPT + D. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the NEWUOA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2020 +! +! Last Modified: Friday, March 15, 2024 PM03:38:22 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: updatexf, updateq, tryqalt + + +contains + + +subroutine updatexf(knew, ximproved, f, xnew, kopt, fval, xpt) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates [XPT, FVAL, KOPT] so that XPT(:, KNEW) is updated to XNEW. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan, is_posinf + +implicit none + +! Inputs +integer(IK), intent(in) :: knew +real(RP), intent(in) :: f +real(RP), intent(in) :: xnew(:) ! XNEW(N) + +! In-outputs +integer(IK), intent(inout) :: kopt +logical, intent(in) :: ximproved +real(RP), intent(inout) :: fval(:) ! FVAL(NPT) +real(RP), intent(inout) :: xpt(:, :)! XPT(N, NPT) + +! Local variables +character(len=*), parameter :: srname = 'UPDATEXF' +integer(IK) :: n +integer(IK) :: npt + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless X is not improved', srname) + call assert(knew /= kopt .or. ximproved, 'KNEW /= KOPT unless X is improved', srname) + call assert(size(xnew) == n .and. all(is_finite(xnew)), 'SIZE(XNEW) == N, XNEW is finite', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN or +Inf', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(.not. any(fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Do essentially nothing when KNEW is 0. This can only happen after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +xpt(:, knew) = xnew +fval(knew) = f + +! KOPT is NOT identical to MINLOC(FVAL). Indeed, if FVAL(KNEW) = FVAL(KOPT) and KNEW < KOPT, then +! MINLOC(FVAL) = KNEW /= KOPT. Do not change KOPT in this case. +if (ximproved) then + kopt = knew +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt .and. all(is_finite(xpt)), & + & 'SIZE(XPT) == [N, NPT], XPT is finite', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(.not. any(fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) +end if + +end subroutine updatexf + + +subroutine updateq(idz, knew, ximproved, bmat, d, moderr, xdrop, xosav, xpt, zmat, gopt, hq, pq) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates GOPT, HQ, and PQ when XPT(:, KNEW) changes from XDROP to XNEW = XOSAV + D, +! where XOSAV is the unupdated XOPT, namely the XOPT before UPDATEXF is called. +! See Section 4 of the NEWUOA paper and that of the BOBYQA paper (there is no LINCOA paper). +! N.B.: +! 1. XNEW is encoded in [BMAT, ZMAT, IDZ] after UPDATEH being called, and it also equals XPT(:, KNEW) +! after UPDATEXF being called. +! 2. Indeed, we only need BMAT(:, KNEW) instead of the entire matrix. +! 3. In Powell's implementation of NEWUOA, the quadratic model is represented by [GQ, PQ, HQ], where +! GQ is the gradient of the quadratic model at XBASE. However, Powell implemented BOBYQA and LINCOA +! without GQ but with GOPT, which is the gradient at XBASE + XOPT. In our implementation, we also +! use GOPT instead of GQ. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite +use, non_intrinsic :: linalg_mod, only : r1update, issymmetric +use, non_intrinsic :: powalg_mod, only : omega_col, hess_mul + +implicit none + +! Inputs +integer(IK), intent(in) :: idz +integer(IK), intent(in) :: knew +logical, intent(in) :: ximproved +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT + N) +real(RP), intent(in) :: d(:) ! D(:) +real(RP), intent(in) :: moderr +real(RP), intent(in) :: xdrop(:) ! XDROP(N) +real(RP), intent(in) :: xosav(:) ! XOSAV(N) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT - N - 1) + +! In-outputs +real(RP), intent(inout) :: gopt(:) ! GOPT(N) +real(RP), intent(inout) :: hq(:, :) ! HQ(N, N) +real(RP), intent(inout) :: pq(:) ! PQ(NPT) + +! Local variables +character(len=*), parameter :: srname = 'UPDATEQ' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: pqinc(size(pq)) + +! Sizes +n = int(size(gopt), kind(n)) +npt = int(size(pq), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(idz >= 1 .and. idz <= size(zmat, 2) + 1, '1 <= IDZ <= SIZE(ZMAT, 2) + 1', srname) + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless X is not improved', srname) + call assert(size(xdrop) == n .and. all(is_finite(xdrop)), 'SIZE(XDROP) == N, XDROP is finite', srname) + call assert(size(xosav) == n .and. all(is_finite(xosav)), 'SIZE(XOSAV) == N, XOSAV is finite', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Do nothing when KNEW is 0. This can only happen after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +! The unupdated model corresponding to [GOPT, HQ, PQ] interpolates F at all points in XPT except for +! XNEW. The error is MODERR = [F(XNEW)-F(XOPT)] - [Q(XNEW)-Q(XOPT)]. + +! Absorb PQ(KNEW)*XDROP*XDROP^T into the explicit part of the Hessian. +! Implement R1UPDATE properly so that it ensures that HQ is symmetric. +call r1update(hq, pq(knew), xdrop) +pq(knew) = ZERO + +! Update the implicit part of the Hessian. +pqinc = moderr * omega_col(idz, zmat, knew) +pq = pq + pqinc + +! Update the gradient, which needs the updated XPT. +gopt = gopt + moderr * bmat(:, knew) + hess_mul(xosav, xpt, pqinc) + +! Further update GOPT if XIMPROVED is TRUE, as XOPT changes from XOSAV to XNEW = XOSAV + D. +if (ximproved) then + gopt = gopt + hess_mul(d, xpt, pq, hq) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) +end if + +end subroutine updateq + + +subroutine tryqalt(idz, bmat, fval, ratio, xopt, xpt, zmat, itest, gopt, hq, pq) +!--------------------------------------------------------------------------------------------------! +! This subroutine tests whether to replace Q by the alternative model, namely the model that +! minimizes the F-norm of the Hessian subject to the interpolation conditions. It does the +! replacement if certain criteria are met (i.e., when ITEST = 3). See the paragraph around (8.4) of +! the NEWUOA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TEN, TENTH, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf +use, non_intrinsic :: linalg_mod, only : matprod, inprod, issymmetric +use, non_intrinsic :: powalg_mod, only : hess_mul, omega_mul + +implicit none + +! Inputs +integer(IK), intent(in) :: idz +real(RP), intent(in) :: bmat(:, :) ! BMAT(N, NPT+N) +real(RP), intent(in) :: fval(:) ! FVAL(NPT) +real(RP), intent(in) :: ratio +real(RP), intent(in) :: xopt(:) ! XOPT(N) +real(RP), intent(in) :: xpt(:, :) ! XOPT(N, NPT) +real(RP), intent(in) :: zmat(:, :) ! ZMAT(NPT, NPT-N-1) + +! In-output +integer(IK), intent(inout) :: itest +real(RP), intent(inout) :: gopt(:) ! GOPT(N) +real(RP), intent(inout) :: hq(:, :) ! HQ(N, N) +real(RP), intent(inout) :: pq(:) ! PQ(NPT) +! N.B.: +! GOPT, HQ, and PQ should be INTENT(INOUT) instead of INTENT(OUT). According to the Fortran 2018 +! standard, an INTENT(OUT) dummy argument becomes undefined on invocation of the procedure. +! Therefore, if the procedure does not define such an argument, its value becomes undefined, +! which is the case for HQ and PQ when ITEST < 3 at exit. In addition, the information in GOPT is +! needed for defining ITEST, so it must be INTENT(INOUT). + +! Local variables +character(len=*), parameter :: srname = 'TRYQALT' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: galt(size(gopt)) +real(RP) :: pqalt(size(pq)) + +! Sizes +n = int(size(gopt), kind(n)) +npt = int(size(pq), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + ! By the definition of RATIO in ratio.f90, RATIO cannot be NaN unless the actual reduction is + ! NaN, which should NOT happen due to the moderated extreme barrier. + call assert(.not. is_nan(ratio), 'RATIO is not NaN', srname) + call assert(size(fval) == npt .and. .not. any(is_nan(fval) .or. is_posinf(fval)), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(size(bmat, 1) == n .and. size(bmat, 2) == npt + n, 'SIZE(BMAT)==[N, NPT+N]', srname) + call assert(issymmetric(bmat(:, npt + 1:npt + n)), 'BMAT(:, NPT+1:NPT+N) is symmetric', srname) + call assert(size(zmat, 1) == npt .and. size(zmat, 2) == npt - n - 1, & + & 'SIZE(ZMAT) == [NPT, NPT - N - 1]', srname) + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Calculate the parameters of the least Frobenius norm interpolant to the current data. +pqalt = omega_mul(idz, zmat, fval) +galt = matprod(bmat(:, 1:npt), fval) + hess_mul(xopt, xpt, pqalt) + +! Test whether to replace the new quadratic model by the least Frobenius norm interpolant, making +! the replacement if the test is satisfied. In the sequel, TEN seems to work a bit better than 100. +! In addition, Powell checked the magnitude of ABS(RATIO) instead of RATIO. +! !if (abs(ratio) > 0.01 .or. inprod(gopt, gopt) < 1.0E2_RP * inprod(galt, galt)) then ! Powell's code +if (ratio > TENTH .or. inprod(gopt, gopt) < TEN * inprod(galt, galt)) then + itest = 0 +else + itest = itest + 1_IK +end if +if (itest >= 3) then + gopt = galt + pq = pqalt + hq = ZERO + itest = 0 +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(gopt) == n, 'SIZE(GOPT) = N', srname) + call assert(size(hq, 1) == n .and. issymmetric(hq), 'HQ is an NxN symmetric matrix', srname) + call assert(size(pq) == npt, 'SIZE(PQ) = NPT', srname) +end if + +end subroutine tryqalt + + +end module update_newuoa_mod diff --git a/examples/fortran/prima/native/uobyqa/geometry.f90 b/examples/fortran/prima/native/uobyqa/geometry.f90 new file mode 100644 index 000000000..807623c03 --- /dev/null +++ b/examples/fortran/prima/native/uobyqa/geometry.f90 @@ -0,0 +1,455 @@ +module geometry_uobyqa_mod +!--------------------------------------------------------------------------------------------------! +! This module contains subroutines concerning the geometry-improving of the interpolation set XPT. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the UOBYQA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Tue 10 Feb 2026 02:43:25 PM CET +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: setdrop_tr, geostep + + +contains + + +function setdrop_tr(kopt, ximproved, d, pl, rho, xpt) result(knew) +!--------------------------------------------------------------------------------------------------! +! This subroutine sets KNEW to the index of the interpolation point to be deleted AFTER A TRUST +! REGION STEP. KNEW will be set in a way ensuring that the geometry of XPT is "optimal" after +! XPT(:, KNEW) is replaced with XNEW = XOPT + D, where D is the trust-region step. See the +! discussions around (56) of the UOBYQA paper. +! N.B.: +! 1. If XIMPROVED = TRUE, then KNEW > 0 so that XNEW is included into XPT. Otherwise, it is a bug. +! 2. If XIMPROVED = FALSE, then KNEW /= KOPT so that XPT(:, KOPT) stays. Otherwise, it is a bug. +! 3. It is tempting to take the function value into consideration when defining KNEW, for example, +! set KNEW so that FVAL(KNEW) = MAX(FVAL) as long as F(XNEW) < MAX(FVAL), unless there is a better +! choice. However, this is not a good idea, because the definition of KNEW should benefit the +! quality of the model that interpolates f at XPT. A set of points with low function values is not +! necessarily a good interpolation set. In contrast, a good interpolation set needs to include +! points with relatively high function values; otherwise, the interpolant will unlikely reflect the +! landscape of the function sufficiently. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ONE, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : trueloc +use, non_intrinsic :: powalg_mod, only : calvlag + +implicit none + +! Inputs +integer(IK), intent(in) :: kopt +logical, intent(in) :: ximproved +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: pl(:, :) ! PL(NPT-1, NPT) +real(RP), intent(in) :: rho +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +integer(IK) :: knew + +! Local variables +character(len=*), parameter :: srname = 'SETDROP_TR' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: distsq(size(xpt, 2)) +real(RP) :: score(size(xpt, 2)) +real(RP) :: vlag(size(xpt, 2)) +real(RP) :: weight(size(xpt, 2)) + +! Sizes +n = int(size(xpt, 1), kind(npt)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt >= n + 2, 'N >= 1, NPT >= N + 2', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(pl, 1) == npt - 1 .and. size(pl, 2) == npt, 'SIZE(PL)==[NPT - 1, NPT]', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Calculate the distance squares between the interpolation points and the "optimal point". When +! identifying the optimal point, it is reasonable to take into account the new trust-region trial +! point XPT(:, KOPT) + D, which will become the optimal point in the next iteration if XIMPROVED +! is TRUE. Powell suggested this in +! - (56) of the UOBYQA paper, lines 276--297 of uobyqb.f, +! - (7.5) and Box 5 of the NEWUOA paper, lines 383--409 of newuob.f, +! - the last paragraph of page 26 of the BOBYQA paper, lines 435--465 of bobyqb.f. +! However, Powell's LINCOA code is different. In his code, the KNEW after a trust-region step is +! picked in lines 72--96 of the update.f for LINCOA, where DISTSQ is calculated as the square of the +! distance to XPT(KOPT, :) (Powell recorded the interpolation points in rows). However, note that +! the trust-region trial point has not been included into XPT yet --- it cannot be included without +! knowing KNEW (see lines 332-344 and 404--431 of lincob.f). Hence Powell's LINCOA code picks KNEW +! based on the distance to the un-updated "optimal point", which is unreasonable. This has been +! corrected in our implementation of LINCOA, yet it does not boost the performance. +if (ximproved) then + distsq = sum((xpt - spread(xpt(:, kopt) + d, dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - (xpt(:, kopt) + d)).^2) % d should be a column! Implicit expansion +else + distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - xpt(:, kopt)).^2) % Implicit expansion +end if + +weight = max(ONE, distsq / rho**2)**4 +! Other possible definitions of WEIGHT. +! !weight = max(ONE, distsq / rho**2)**3.5_RP ! ! No better than power 4. +! !weight = max(ONE, distsq / delta**2)**3.5_RP ! Not better than DISTSQ/RHO**2. +! !weight = max(ONE, distsq / rho**2)**1.5_RP ! Powell's origin code: power 1.5. +! !weight = max(ONE, distsq / rho**2)**2 ! Better than power 1.5. +! !weight = max(ONE, distsq / delta**2)**2 ! Not better than DISTSQ/RHO**2. +! !weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**2 ! The same as DISTSQ/RHO**2. +! !weight = distsq**2 ! Not better than MAX(ONE, DISTSQ/RHO**2)**2 +! !weight = max(ONE, distsq / rho**2)**3 ! Better than power 2. +! !weight = max(ONE, distsq / delta**2)**3 ! Similar to DISTSQ/RHO**2; not better than it. +! !weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**3 ! The same as DISTSQ/RHO**2. +! !weight = distsq**3 ! Not better than MAX(ONE, DISTSQ/RHO**2)**3 +! !weight = max(ONE, distsq / delta**2)**4 ! Not better than DISTSQ/RHO**2. +! !weight = max(ONE, distsq / max(TENTH * delta, rho)**2)**4 ! The same as DISTSQ/RHO**2. +! !weight = distsq**4 ! Not better than MAX(ONE, DISTSQ/RHO**2)**4 + +! Here, VLAG is the counterpart of DEN in NEWUOA/BOBYQA/LINCOA, representing the denominator in the +! update of the Lagrange functions (or, inverse of the coefficient or KKT matrix of the +! interpolation system). +vlag = calvlag(pl, d, xpt(:, kopt), kopt) +score = weight * abs(vlag) + +! If the new F is not better than FVAL(KOPT), we set SCORE(KOPT) = -1 to avoid KNEW = KOPT. +if (.not. ximproved) then + score(kopt) = -ONE +end if + +! SCORE(K) is NaN implies VLAG(K) is NaN, but we want ABS(VLAG) to be big. So we exclude such K. +score(trueloc(is_nan(score))) = -ONE + +knew = 0 +! It makes almost no difference if we change the IF below to `IF (ANY(SCORE>0))`, which is used +! in Powell's BOBYQA and LINCOA code. +if (any(score > 1) .or. (ximproved .and. any(score > 0))) then ! Powell's UOBYQA and NEWUOA code + knew = int(maxloc(score, dim=1), kind(knew)) + !!MATLAB: [~, knew] = max(score); +end if + +! Powell's code does not include the following instructions. With Powell's code, if VLAG consists of +! only NaN, then KNEW can be 0 even when XIMPROVED is TRUE. Here, we set KNEW to the following value, +! to make sure that the new trial point is included in the interpolation set. However, the updating +! subroutine will likely need to skip the update of the Lagrange polynomial, or they would be +! destroyed by the NaNs. +if ((ximproved .and. knew == 0) .or. knew < 0) then ! KNEW < 0 is impossible in theory. + knew = int(maxloc(distsq, dim=1), kind(knew)) +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(knew /= kopt .or. ximproved, 'KNEW /= KOPT unless XIMPROVED = TRUE', srname) + call assert(knew >= 1 .or. .not. ximproved, 'KNEW >= 1 unless XIMPROVED = FALSE', srname) + ! KNEW >= 1 when XIMPROVED = TRUE unless NaN occurs in DISTSQ, which should not happen if the + ! starting point does not contain NaN and the trust-region/geometry steps never contain NaN. +end if + +end function setdrop_tr + + +function geostep(knew, kopt, delbar, pl, xpt) result(d) +!--------------------------------------------------------------------------------------------------! +! This function calculates a step D that approximately solves +! +! maximize |LFUNC(XOPT + D)| subject to ||D|| <= DELBAR, +! +! so that the geometry of the interpolation step is improved when XPT(:, KNEW) becomes XOPT + D. +! Here, LFUNC is the Lagrange polynomial at the KNEW-th interpolation point. See (8) and Section 2 +! of the UOBYQA paper. +! +! PL contains the parameters of the Lagrange functions. PL(KNEW) defines LFUNC. +! +! Powell's comments on the cost of linear algebra is as follows. +! Calculating the D that maximizes |LFUNC(XOPT + D)| subject to ||D|| <= DELBAR requires of order +! N^3 operations, but sometimes it is adequate if |LFUNC(XOPT + D)| is within about 0.9 of its +! greatest possible value. This subroutine provides such a solution in only of order N^2 operations, +! where the claim of accuracy has been tested by numerical experiments. +! +! N.B.: In Powell's UOBYQA code, DELBAR = RHO. We take the DELBAR of NEWUOA, which works better. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, QUART, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: linalg_mod, only : matprod, inprod, norm, vec2smat, smat_mul_vec +use, non_intrinsic :: powalg_mod, only : calvlag + +implicit none + +! Inputs +integer(IK), intent(in) :: knew +integer(IK), intent(in) :: kopt +real(RP), intent(in) :: delbar +real(RP), intent(in) :: pl(:, :) ! PL(NPT-1, NPT) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +real(RP) :: d(size(xpt, 1)) ! D(N) + +! Local variables +character(len=*), parameter :: srname = 'GEOSTEP' +integer(IK) :: n, npt +real(RP) :: dcauchy(size(xpt, 1)) +real(RP) :: dd +real(RP) :: dhd +real(RP) :: dlin +real(RP) :: g(size(xpt, 1)) +real(RP) :: gd +real(RP) :: gg +real(RP) :: ghg +real(RP) :: gnorm +real(RP) :: h(size(xpt, 1), size(xpt, 1)) +real(RP) :: hv(size(xpt, 1)) +real(RP) :: scaling +real(RP) :: temp +real(RP) :: tempa +real(RP) :: tempb +real(RP) :: tempc +real(RP) :: tempd +real(RP) :: tempv +real(RP) :: v(size(xpt, 1)) +real(RP) :: vhd +real(RP) :: vhg +real(RP) :: vhv +real(RP) :: vlin +real(RP) :: vlag(size(xpt, 2)) +real(RP) :: vlagc(size(xpt, 2)) +real(RP) :: vmu +real(RP) :: vnorm +real(RP) :: vv +real(RP) :: wcos +real(RP) :: wsin +real(RP) :: xopt(size(xpt, 1)) + +! Sizes. +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions. +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(npt == (n + 1) * (n + 2) / 2, 'NPT = (N+1)(N+2)/2', srname) + call assert(knew >= 1 .and. knew <= npt, '1 <= KNEW <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew /= kopt, 'KNEW /= KOPT', srname) + call assert(delbar > 0, 'DELBAR > 0', srname) + call assert(size(pl, 1) == npt - 1 .and. size(pl, 2) == npt, 'SIZE(PL) == [NPT-1, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Read XOPT. +xopt = xpt(:, kopt) + +! For the KNEW-th Lagrange function, evaluate the gradient at XOPT and the Hessian. +g = pl(1:n, knew) + smat_mul_vec(pl(n + 1:npt - 1, knew), xopt) +h = vec2smat(pl(n + 1:npt - 1, knew)) + +! Evaluate GG = G^T*G and GHG = G^T*H*G. They will be used later. +gg = sum(g**2) +ghg = inprod(g, matprod(h, g)) + +! Calculate the Cauchy step as a backup. Powell's code does not have this, and D may be 0 or NaN. +if (gg > 0 .and. is_finite(gg)) then + dcauchy = (delbar / sqrt(gg)) * g + if (ghg < 0) then + dcauchy = -dcauchy + end if +else ! GG is 0 or NaN due to rounding errors. Set DCAUCHY to a displacement from XOPT to XPT(:, KNEW). + dcauchy = xpt(:, knew) - xopt + scaling = delbar / norm(dcauchy) + dcauchy = max(0.6_RP * scaling, min(HALF, scaling)) * dcauchy ! 0.6: ensure |D| > DELBAR/2 + if (inprod(g, dcauchy) * inprod(dcauchy, matprod(h, dcauchy)) < 0) then + dcauchy = -dcauchy + end if +end if + +! Return if H or G contains NaN or H is zero. Powell's code does not do this. +if (any(is_nan(h)) .or. any(is_nan(g)) .or. all(abs(h) <= 0)) then + d = dcauchy + return +end if + +! Handle the case with N = 1. This should be done after the case where G or H contains NaN. Powell's +! code does not contain this part. +if (n == 1) then + if (g(1) * h(1, 1) > 0) then + d = delbar + else + d = -delbar + end if + return +end if + +! Pick V such that ||HV|| / ||V|| is large. +v = h(:, maxloc(sum(h**2, dim=1), dim=1)) +! Normalize V. Powell's code does not do this. It does not change the algorithm as only its +! direction matters. It slightly improves the performance in the noiseless case. +v = v / norm(v) + +! Set D to a vector in the subspace span{V, HV} that maximizes |(D, HD)|/(D, D), except that we set +! D = HV if V and HV are nearly parallel. +vv = sum(v**2) +d = matprod(h, v) +vhv = inprod(v, d) +if (vhv * vhv <= 0.9999_RP * sum(d**2) * vv) then + d = d - (vhv / vv) * v + dd = sum(d**2) + scaling = sqrt(dd / vv) + dhd = inprod(d, matprod(h, d)) + v = scaling * v + vhv = scaling * scaling * vhv + vhd = scaling * dd + temp = HALF * (dhd - vhv) + if (dhd + vhv < 0) then + d = vhd * v + (temp - sqrt(temp**2 + vhd**2)) * d + else + d = vhd * v + (temp + sqrt(temp**2 + vhd**2)) * d + end if +end if + +! We now turn our attention to the subspace span{G, D}. A multiple of the current D is returned if +! that choice seems to be adequate. +dd = sum(d**2) +gd = inprod(g, d) +dhd = inprod(d, matprod(h, d)) + +! Zaikun 20220504: GG and DD can become 0 at this point due to rounding. Detected by IFORT. +if (.not. (gg > 0 .and. dd > 0)) then + d = dcauchy + return +end if + +v = d - (gd / gg) * g +vv = sum(v**2) +if (gd * dhd < 0) then + scaling = -delbar / sqrt(dd) +else + scaling = delbar / sqrt(dd) +end if +d = scaling * d +gnorm = sqrt(gg) + +if (.not. (gnorm * dd > 0.5E-2_RP * delbar * abs(dhd) .and. vv > 1.0E-4_RP * dd)) then + ! It may happen that D = 0 due to overflow in DD, which is used to define SCALING. + if (sum(abs(d)) <= 0 .or. .not. is_finite(sum(abs(d)))) then + d = dcauchy + end if + return +end if + +! G and V are now orthogonal in the subspace span{G, D}. Hence we generate an orthonormal basis of +! this subspace such that (D, HV) is negligible or 0, where D and V will be the basis vectors. +hv = matprod(h, v) +vhg = inprod(g, hv) +vhv = inprod(v, hv) +vnorm = sqrt(vv) +ghg = ghg / gg +vhg = vhg / (vnorm * gnorm) +vhv = vhv / vv +if (abs(vhg) <= 0.01_RP * max(abs(ghg), abs(vhv))) then + vmu = ghg - vhv + wcos = ONE + wsin = ZERO +else + temp = HALF * (ghg - vhv) + if (temp < 0) then + vmu = temp - sqrt(temp**2 + vhg**2) + else + vmu = temp + sqrt(temp**2 + vhg**2) + end if + temp = sqrt(vmu**2 + vhg**2) + wcos = vmu / temp + wsin = vhg / temp +end if +tempa = wcos / gnorm +tempb = wsin / vnorm +tempc = wcos / vnorm +tempd = wsin / gnorm +d = tempa * g + tempb * v +v = tempc * v - tempd * g + +! The final D is a multiple of the current D, V, D + V or D - V. We make the choice from these +! possibilities that is optimal. +dlin = wcos * gnorm / delbar +vlin = -wsin * gnorm / delbar +tempa = abs(dlin) + HALF * abs(vmu + vhv) +tempb = abs(vlin) + HALF * abs(ghg - vmu) +tempc = sqrt(HALF) * (abs(dlin) + abs(vlin)) + QUART * abs(ghg + vhv) +if (tempa >= tempb .and. tempa >= tempc) then + if (dlin * (vmu + vhv) < 0) then + tempd = -delbar + else + tempd = delbar + end if + tempv = ZERO +else if (tempb >= tempc) then + tempd = ZERO + if (vlin * (ghg - vmu) < 0) then + tempv = -delbar + else + tempv = delbar + end if +else + if (dlin * (ghg + vhv) < 0) then + tempd = -sqrt(HALF) * delbar + else + tempd = sqrt(HALF) * delbar + end if + if (vlin * (ghg + vhv) < 0) then + tempv = -sqrt(HALF) * delbar + else + tempv = sqrt(HALF) * delbar + end if +end if +d = tempd * d + tempv * v + +! Replace D with DCAUCHY if needed. Powell's code does not have this part. Indeed, only the KNEW-th +! entries of VLAG and VLAGC are needed. +vlag = calvlag(pl, d, xopt, kopt) +vlagc = calvlag(pl, dcauchy, xopt, kopt) +if (abs(vlagc(knew)) > TWO * abs(vlag(knew)) .or. is_nan(vlag(knew))) then + d = dcauchy +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + ! In theory, ||D|| = DELBAR. Considering rounding errors, we check that DELBAR/2 < ||D|| < 2*DELBAR. + ! It is crucial to ensure that the geometry step is nonzero. + call assert(norm(d) > HALF * delbar .and. norm(d) < TWO * delbar, 'DELBAR/2 < ||D|| < 2*DELBAR', srname) +end if +end function geostep + + +end module geometry_uobyqa_mod diff --git a/examples/fortran/prima/native/uobyqa/initialize.f90 b/examples/fortran/prima/native/uobyqa/initialize.f90 new file mode 100644 index 000000000..40939292f --- /dev/null +++ b/examples/fortran/prima/native/uobyqa/initialize.f90 @@ -0,0 +1,461 @@ +module initialize_uobyqa_mod +!--------------------------------------------------------------------------------------------------! +! This module performs the initialization of UOBYQA, described in Section 4 of the UOBYQA paper. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the UOBYQA paper. +! +! Started: July 2020 +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Last Modified: Tue 10 Feb 2026 02:01:01 PM CET +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: initxf, initq, initl + + +contains + + +subroutine initxf(calfun, iprint, maxfun, ftarget, rhobeg, x0, kopt, nf, fhist, fval, xbase, & + & xhist, xpt, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine does the initialization about the interpolation points & their function values. +! See Section 4 of the UOBYQA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, TWO, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: evaluate_mod, only : evaluate +use, non_intrinsic :: history_mod, only : savehist +use, non_intrinsic :: infnan_mod, only : is_finite, is_posinf, is_nan +use, non_intrinsic :: infos_mod, only : INFO_DFT +use, non_intrinsic :: linalg_mod, only : eye, trueloc, linspace +use, non_intrinsic :: message_mod, only : fmsg +use, non_intrinsic :: pintrf_mod, only : OBJ + +implicit none + +! Inputs +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfun +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: x0(:) ! X0(N) + +! Outputs +integer(IK), intent(out) :: info +integer(IK), intent(out) :: kopt +integer(IK), intent(out) :: nf +real(RP), intent(out) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out) :: fval(:) +real(RP), intent(out) :: xbase(:) ! XBASE(N) +real(RP), intent(out) :: xhist(:, :) ! XHIST(N, MAXXHIST) +real(RP), intent(out) :: xpt(:, :) ! XPT(N, NPT) + +! Local variables +character(len=*), parameter :: solver = 'UOBYQA' +character(len=*), parameter :: srname = 'INITXF' +integer(IK) :: ip +integer(IK) :: iq +integer(IK) :: k +integer(IK) :: kk(size(x0)) +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: npt +integer(IK) :: subinfo +logical :: evaluated(size(xpt, 2)) +real(RP) :: f +real(RP) :: x(size(x0)) +real(RP) :: xw(size(x0)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxhist = max(maxxhist, maxfhist) + +! Preconditions +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(n >= 1 .and. npt == (n + 1) * (n + 2) / 2, 'N >= 1, NPT == (N+1)*(N+2)/2', srname) + call assert(maxfun >= npt + 1, 'MAXFUN >= NPT + 1', srname) + call assert(maxhist >= 0 .and. maxhist <= maxfun, '0 <= MAXHIST <= MAXFUN', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(size(fval) == npt, 'SIZE(FVAL) == NPT', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) + call assert(rhobeg > 0, 'RHOBEG > 0', srname) + call assert(size(x0) == n .and. all(is_finite(x0)), 'SIZE(X0) == N, X0 is finite', srname) + call assert(size(xbase) == n, 'SIZE(XBASE) == N', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialize INFO to the default value. At return, an INFO different from this value will indicate +! an abnormal return. +info = INFO_DFT + +! Initialize XBASE to X0. +xbase = x0 + +! EVALUATED is a boolean array with EVALUATED(I) indicating whether the function value of the I-th +! interpolation point has been evaluated. We need it for a portable counting of the number of +! function evaluations, especially if the loop is conducted asynchronously. However, the loop here +! is not fully parallelizable if NPT>2N+1, as the definition XPT(:, 2N+2:end) involves FVAL(1:2N+1). +evaluated = .false. + +! Initialize XHIST, FHIST, and FVAL. Otherwise, compilers may complain that they are not +! (completely) initialized if the initialization aborts due to abnormality (see CHECKEXIT). +! N.B.: 1. Initializing them to NaN would be more reasonable (NaN is not available in Fortran). +! 2. Do not initialize the models if the current initialization aborts due to abnormality. Otherwise, +! errors or exceptions may occur, as FVAL and XPT etc are uninitialized. +xhist = -REALMAX +fhist = REALMAX +fval = REALMAX + +! Set XPT(:, 1 : 2*N+1) and FVAL(:, 1 : 2*N+1). +xpt = ZERO +kk = linspace(2_IK, 2_IK * n, n) +xpt(:, kk) = rhobeg * eye(n) +do k = 1, 2_IK * n + 1_IK + x = xpt(:, k) + xbase + call evaluate(calfun, x, f) + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Initialization', iprint, k, rhobeg, f, x) + ! Save X and F into the history. + call savehist(k, x, xhist, f, fhist) + + evaluated(k) = .true. + fval(k) = f + + ! When K is even, determine XPT(:, K+1) according to F(K). + ! N.B.: This heuristic strategy does increase the performance. In addition, it is a GOOD idea to + ! evaluate F at XBASE + 2*XPT(:, K) or XBASE - XPT(:, K) IMMEDIATELY after XBASE + XPT(:, K). + ! This increases the probability of finding a smaller function value earlier in the sampling + ! process for the first model. This process itself can be regarded as a simple direct search. It + ! is IMPORTANT for the performance of the algorithm during the early stage, even before the + ! first model is built. + if (modulo(k, 2_IK) == 0) then + if (fval(k) < fval(1)) then + xpt(:, k + 1) = TWO * xpt(:, k) ! XPT(K / 2, K + 1) = TWO * RHOBEG + else + xpt(:, k + 1) = -xpt(:, k) ! XPT(K / 2, K + 1) = -RHOBEG + end if + end if + + ! Check whether to exit. + subinfo = checkexit(maxfun, k, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if +end do + +if (info == INFO_DFT) then + xw = -rhobeg + xw(trueloc(fval(kk) < fval(1))) = rhobeg + ! See (42)--(43) of the UOBYQA paper for IP and IQ. + ip = 0 + iq = 2 + do k = 2_IK * n + 2_IK, npt + ! Pick the shift from XBASE to the next initial interpolation point that provides the + ! off-diagonal second derivatives of the quadratic interpolant. + ip = ip + 1_IK + if (ip == iq) then + iq = iq + 1_IK + ip = 1 + end if + xpt([ip, iq], k) = xw([ip, iq]) + x = xpt(:, k) + xbase + call evaluate(calfun, x, f) + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Initialization', iprint, k, rhobeg, f, x) + ! Save X and F into the history. + call savehist(k, x, xhist, f, fhist) + + evaluated(k) = .true. + fval(k) = f + + ! Check whether to exit. + subinfo = checkexit(maxfun, k, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + end do +end if + +nf = int(count(evaluated), kind(nf)) !!MATLAB: nf = sum(evaluated); +kopt = int(minloc(fval, mask=evaluated, dim=1), kind(kopt)) +!!MATLAB: fopt = min(fval(evaluated)); kopt = find(evaluated & ~(fval > fopt), 1, 'first') + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nf <= npt, 'NF <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(size(xbase) == n .and. all(is_finite(xbase)), 'SIZE(XBASE) == N, XBASE is finite', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(fval) == npt .and. .not. any(evaluated .and. (is_nan(fval) .or. is_posinf(fval))), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) + call assert(.not. any(evaluated .and. fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) +end if + +end subroutine initxf + + +subroutine initq(fval, xpt, pq, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine initializes the quadratic model, whose coefficients are stored in PQ, where +! PQ(1 : N) containing the gradient of the model at XBASE, and PQ(N+1 : NPT-1) containing the upper +! triangular part of the Hessian, column by column. See Section 4 of the UOBYQA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, TWO, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, NAN_INF_MODEL + +implicit none + +! Inputs +real(RP), intent(in) :: fval(:) ! XPT(N, NPT) +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +integer(IK), intent(out), optional :: info +real(RP), intent(out) :: pq(:) ! PQ((N + 1) * (N + 2) / 2 - 1) + +! Local variables +character(len=*), parameter :: srname = 'INITQ' +integer(IK) :: k1 +integer(IK) :: ih +integer(IK) :: ip +integer(IK) :: iq +integer(IK) :: k +integer(IK) :: k0 +integer(IK) :: n +integer(IK) :: npt +real(RP) :: deriv(size(xpt, 1)) +real(RP) :: fbase +real(RP) :: rhobeg +real(RP) :: rhosq + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Postconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt == (n + 1) * (n + 2) / 2, 'N >= 1, NPT == (N+1)*(N+2)/2', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(fval) == npt .and. .not. any((is_nan(fval) .or. is_posinf(fval))), & + & 'SIZE(FVAL) == NPT and FVAL is not NaN or +Inf', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +rhobeg = maxval(abs(xpt(:, 2))) +rhosq = rhobeg**2 +fbase = fval(1) + +! Form the gradient and diagonal second derivatives of the quadratic model. +do k = 1, n + k0 = 2_IK * k + k1 = 2_IK * k + 1_IK + ! Find the (K, K) element of the Hessian. + ih = n + k * (k + 1_IK) / 2_IK + if (xpt(k, k1) > 0) then ! XPT(K, K1) = 2*RHO + deriv(k) = (fbase + fval(k1) - TWO * fval(k0)) / rhosq + pq(k) = (4.0_RP * fval(k0) - 3.0_RP * fbase - fval(k1)) / (TWO * rhobeg) + else ! XPT(K, K1) = -RHO + deriv(k) = (fval(k0) + fval(k1) - TWO * fbase) / rhosq + pq(k) = (fval(k0) - fval(k1)) / (TWO * rhobeg) + end if + pq(ih) = deriv(k) +end do + +! Form the off-diagonal second derivatives of the initial quadratic model. +ip = 0 +iq = 2 +do k = 2_IK * n + 2_IK, npt + ip = ip + 1_IK + if (ip == iq) then + iq = iq + 1_IK + ip = 1 + end if + ! Find the (IQ, IP) entry of the Hessian. + ih = n + (iq - 1_IK) * iq / 2_IK + ip + pq(ih) = (fval(k) - fbase - xpt(ip, k) * pq(ip) - xpt(iq, k) * pq(iq) & + & - HALF * rhosq * (deriv(ip) + deriv(iq))) / (xpt(ip, k) * xpt(iq, k)) +end do + +if (present(info)) then + if (any(is_nan(pq))) then + info = NAN_INF_MODEL + else + info = INFO_DFT + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(pq) == npt - 1, 'SIZE(PQ) == NPT - 1', srname) +end if + +end subroutine initq + + +subroutine initl(xpt, pl, info) +!--------------------------------------------------------------------------------------------------! +! This subroutine initializes the Lagrange functions. The coefficients of the K-th Lagrange function +! is stored in PL(:, K), with PL(1 : N, K) containing the gradient of the function at XBASE, and +! PL(N+1 : NPT-1, K) containing the upper triangular part of the Hessian, column by column. +! See Section 4 of the UOBYQA paper. +!--------------------------------------------------------------------------------------------------! +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, NAN_INF_MODEL + +implicit none + +! Inputs +real(RP), intent(in) :: xpt(:, :) ! XPT(N, NPT) + +! Outputs +integer(IK), intent(out), optional :: info +real(RP), intent(out) :: pl(:, :) ! PL((N + 1) * (N + 2) / 2 - 1, (N + 1) * (N + 2) / 2) + +! Local variables +character(len=*), parameter :: srname = 'INITL' +integer(IK) :: ih +integer(IK) :: ip +integer(IK) :: iq +integer(IK) :: k +integer(IK) :: k0 +integer(IK) :: k1 +integer(IK) :: n +integer(IK) :: npt +real(RP) :: rhobeg +real(RP) :: rhosq +real(RP) :: temp + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Postconditions +if (DEBUGGING) then + call assert(n >= 1 .and. npt == (n + 1) * (n + 2) / 2, 'N >= 1, NPT == (N+1)*(N+2)/2', srname) + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt, 'SIZE(XPT) == [N, NPT]', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +rhobeg = maxval(abs(xpt(:, 2))) +rhosq = rhobeg**2 + +pl = ZERO + +! Form the gradient and diagonal second derivatives of the Lagrange functions. +do k = 1, n + k0 = 2_IK * k + k1 = 2_IK * k + 1_IK + ih = n + k * (k + 1_IK) / 2_IK ! The (K, K) entry of the Hessian + if (xpt(k, k1) > 0) then ! XPT(K, K1) = 2*RHO + pl(k, 1) = -1.5_RP / rhobeg + pl(ih, 1) = ONE / rhosq + pl(k, k0) = TWO / rhobeg + pl(ih, k0) = -TWO / rhosq + else ! XPT(K, K1) = -RHO + pl(ih, 1) = -TWO / rhosq + pl(k, k0) = HALF / rhobeg + pl(ih, k0) = ONE / rhosq + end if + pl(k, k1) = -HALF / rhobeg + pl(ih, k1) = ONE / rhosq +end do + +! Form the off-diagonal second derivatives of the Lagrange functions. +ip = 0 +iq = 2 +do k = 2_IK * n + 2_IK, npt + ip = ip + 1_IK + if (ip == iq) then + iq = iq + 1_IK + ip = 1 + end if + + ! Find the (IQ, IP) entry of the Hessian. + temp = ONE / (xpt(ip, k) * xpt(iq, k)) + ih = n + (iq - 1_IK) * iq / 2_IK + ip + + pl(ih, 1) = temp + pl(ih, k) = temp + + if (xpt(ip, k) < 0) then + pl(ih, 2 * ip + 1) = -temp + else + pl(ih, 2 * ip) = -temp + end if + + if (xpt(iq, k) < 0) then + pl(ih, 2 * iq + 1) = -temp + else + pl(ih, 2 * iq) = -temp + end if +end do + +if (present(info)) then + if (any(is_nan(pl))) then + info = NAN_INF_MODEL + else + info = INFO_DFT + end if +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(pl, 1) == npt - 1 .and. size(pl, 2) == npt, 'SIZE(PL) == [NPT - 1, NPT]', srname) +end if + +end subroutine initl + + +end module initialize_uobyqa_mod diff --git a/examples/fortran/prima/native/uobyqa/trustregion.f90 b/examples/fortran/prima/native/uobyqa/trustregion.f90 new file mode 100644 index 000000000..eaa166b90 --- /dev/null +++ b/examples/fortran/prima/native/uobyqa/trustregion.f90 @@ -0,0 +1,649 @@ +module trustregion_uobyqa_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning the trust-region calculations of UOBYQA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the UOBYQA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Monday, August 07, 2023 AM03:56:41 +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: trstep, trrad + + +contains + + +subroutine trstep(delta, g, h, tol, d, crvmin) +!--------------------------------------------------------------------------------------------------! +! This subroutine solves the trust-region subproblem +! +! minimize + 0.5 * subject to ||D|| <= DELTA. +! +! D will be set to the calculated vector of variables. CRVMIN will be the least eigenvalue of H iff +! D is a Newton-Raphson step. Then CRVMIN will be positive, but otherwise it will be set to zero. +! TOL is the value of a tolerance from the open interval (0,1). Let MAXRED be the maximum of +! Q(0)-Q(D) subject to ||D|| <= DELTA, and let ACTRED be the value of Q(0)-Q(D) that is actually +! calculated. We take the view that any D is acceptable if it has the properties +! +! ||D|| <= DELTA and ACTRED <= (1-TOL)*MAXRED. +! +! The algorithm first tridiagonalizes H and then applies the More-Sorensen method in +! More and Sorensen, "Computing a trust region step", SIAM J. Sci. Stat. Comput. 4: 553-572, 1983. +! +! The major calculations of the More-Sorensen method lie in the Cholesky factorization or LDL +! factorization of H + PAR*I with the iteratively selected values of PAR (in More-Sorensen (1983), +! the parameter is named LAMBDA; in Powell's UOBYQA paper, it is THETA). Powell's method in this +! code simplifies the calculations by first tridiagonalizing H with an orthogonal transformation. +! If a matrix T is tridiagonal, its LDL factorization, if exits, can be obtained easily: +! +! T = L*diag(PIV)*L^T, +! +! where diag(PIV) is the diagonal matrix with the diagonal entries being PIV(1:N), i.e., "the pivots +! of the Cholesky factorization" in Powell's comments on his code, and L is the lower triangular +! matrix with all the diagonal entries being 1, the subdiagonal being the subdiagonal of T divided +! by PIV(1:N-1), and all the other entries being 0. PIV can be obtained by a simple recursion. +! +! For more information, see Section 2 of the UOBYQA paper and +! Powell, M. J. D., "Trust region calculations revisited", Numerical Analysis 1997: Proceedings of +! the 17th Dundee Biennial Numerical Analysis Conference, 1997, 193--211, +! Powell, M. J. D., "The use of band matrices for second derivative approximations in trust region +! algorithms", Advances in Nonlinear Programming: Proceedings of the 96 International Conference on +! Nonlinear Programming, 1998, 3--28. +!--------------------------------------------------------------------------------------------------! + +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, TWO, HALF, REALMIN, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan +use, non_intrinsic :: linalg_mod, only : issymmetric, inprod, hessenberg, eigmin, trueloc, norm + +implicit none + +! Inputs +real(RP), intent(in) :: delta +real(RP), intent(in) :: g(:) ! G(N) +real(RP), intent(in) :: h(:, :) ! H(N, N) +real(RP), intent(in) :: tol + +! In-outputs +real(RP), intent(out) :: d(:) ! D(N) +real(RP), intent(out) :: crvmin + +! Local variables +character(len=*), parameter :: srname = 'TRSTEP' +integer(IK) :: i +integer(IK) :: iter +integer(IK) :: k +integer(IK) :: maxiter +integer(IK) :: n +logical :: negcrv +logical :: posdef +logical :: scaled +real(RP) :: delsq +real(RP) :: dhd +real(RP) :: dnewton(size(g)) ! Newton-Raphson step; only calculated when N = 1. +real(RP) :: dnorm +real(RP) :: dold(size(g)) +real(RP) :: dsq +real(RP) :: dtg +real(RP) :: dtz +real(RP) :: gam +real(RP) :: gg(size(g)) +real(RP) :: gnorm +real(RP) :: gsq +real(RP) :: hh(size(g), size(g)) +real(RP) :: hnorm +real(RP) :: modscal +real(RP) :: par +real(RP) :: parl +real(RP) :: parlest +real(RP) :: partmp +real(RP) :: paru +real(RP) :: paruest +real(RP) :: phi +real(RP) :: phil +real(RP) :: phiu +real(RP) :: piv(size(g)) +real(RP) :: slope +real(RP) :: td(size(g)) +real(RP) :: tempa +real(RP) :: tempb +real(RP) :: tn(size(g) - 1) +real(RP) :: tnz +real(RP) :: wsq +real(RP) :: wwsq +real(RP) :: z(size(g)) +real(RP) :: zsq + +! Sizes. +n = int(size(g), kind(n)) + +! Preconditions. +if (DEBUGGING) then + call assert(n >= 1, 'N >= 1', srname) + call assert(delta > 0, 'DELTA > 0', srname) + call assert(size(h, 1) == n .and. issymmetric(h), 'H is n-by-n and symmetric', srname) + call assert(size(d) == n, 'SIZE(D) == N', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! The initial values of DSQ, PHIU, and PHIL are unused but to entertain Fortran compilers. +! TODO: Check that DSQ, PHIU, PHIL have been initialized before used. +dsq = ZERO +phiu = ZERO +phil = ZERO + +! Scale the problem if G contains large values. Otherwise, floating point exceptions may occur. In +! the sequel, GG and HH are used instead of G and H, which are INTENT(IN) and hence cannot be +! changed. Note that CRVMIN must be scaled back if it is nonzero, but the step is scale invariant. +! N.B.: It is faster and safer to scale by multiplying a reciprocal than by division. See +! https://fortran-lang.discourse.group/t/ifort-ifort-2021-8-0-1-0e-37-1-0e-38-0/ +if (maxval(abs(g)) > 1.0E8) then ! The threshold is empirical. + modscal = max(TWO * REALMIN, ONE / maxval(abs(g))) ! MAX: precaution against underflow. + gg = g * modscal + hh = h * modscal + scaled = .true. +else + modscal = ONE ! This value is not used, but Fortran compilers may complain without it. + gg = g + hh = h + scaled = .false. +end if + +! Initialize D and CRVMIN. +d = ZERO +crvmin = ZERO + +gsq = sum(gg**2) +gnorm = sqrt(gsq) + +if (is_nan(gsq)) then + return +end if +if (.not. any(abs(hh) > 0)) then + if (gnorm > 0) then + d = -(delta / gnorm) * gg + end if + return +end if + +! Handle the case with N = 1. This should be done after the case where GSQ is NaN. +! Powell's original code requires that N >= 2. When N = 1, the code does not work (sometimes even +! encounters memory errors). This is indeed why the original UOBYQA code constantly terminates with +! "a trust region step has failed to reduce the quadratic model" when applied to univariate problems. +if (n == 1) then + d = sign(delta, -g) !!MATLAB: d = -delta * sign(g) + if (h(1, 1) > 0) then + dnewton = -g / h(1, 1) + if (abs(dnewton(1)) <= delta) then + d = dnewton + crvmin = h(1, 1) ! If we use HH(1, 1) here, then we need to scale it back! + end if + end if + return +end if + +! Apply Householder transformations to get a tridiagonal matrix similar to H (i.e., the Hessenberg +! form of H), and put the elements of the Householder vectors in the lower triangular part of HH. +! Further, TD and TN will contain the diagonal and other nonzero elements of the tridiagonal matrix. +! In the comments hereafter, H indeed means this tridiagonal matrix. +call hessenberg(hh, td, tn) !!MATLAB: [P, hh] = hess(hh); td = diag(hh); tn = diag(hh, 1) + +! Form GG by applying the similarity transformation. +do k = 1, n - 1_IK + gg(k + 1:n) = gg(k + 1:n) - inprod(gg(k + 1:n), hh(k + 1:n, k)) * hh(k + 1:n, k) +end do +!!MATLAB: gg = (gg'*P)'; % gg = P'*gg; + +!--------------------------------------------------------------------------------------------------! +! Zaikun 20220303: Exit if GG, HH, TD, or TN is not finite. Otherwise, the behavior of this +! subroutine is not predictable. For example, if HNORM = GNORM = Inf, it is observed that the +! initial value of PARL defined below will change when we add code that should not affect PARL +! (e.g., print it, or add TD = 0, TN = 0, PIV = 0 at the beginning of this subroutine). +! This is probably because the behavior of MAX is undefined if it receives NaN (if GNORM and HNORM +! are both Inf, then GNORM/DELTA - HNORM = NaN). +!--------------------------------------------------------------------------------------------------! +if (.not. is_finite(sum(abs(gg)) + sum(abs(hh)) + sum(abs(td)) + sum(abs(tn)))) then + return +end if + +! Begin the trust region calculation with a tridiagonal matrix by calculating the L_1-norm of the +! Hessenberg form of H, which is an upper bound for the spectral norm of H. +hnorm = maxval(abs([ZERO, tn]) + abs(td) + abs([tn, ZERO])) +delsq = delta * delta + +! Set the initial values of PAR and its bounds. +! N.B.: PAR is the parameter LAMBDA in More-Sorensen (1983) and Powell (1997), as well as the THETA +! in Section 2 of the UOBYQA paper. The algorithm looks for the optimal PAR characterized in Lemmas +! 2.1--2.3 of More-Sorensen (1983). +parl = maxval([ZERO, -minval(td), gnorm / delta - hnorm]) ! Lower bound for the optimal PAR +parlest = parl ! Estimation for PARL +par = parl +paru = ZERO ! Upper bound for the optimal PAR ??? The initial value is less than PARL. Why? +paruest = ZERO ! Estimation for PARU +posdef = .false. +dold = ZERO +iter = 0 +maxiter = min(1000_IK, 100_IK * n) ! Unlikely to be reached. +! Zaikun 26-06-2019: Powell's original code can encounter infinite cycling, which did happen when +! testing the CUTEst problems GAUSS1LS, GAUSS2LS, and GAUSS3LS. Indeed, in all these cases, Inf +! and NaN appear in D due to extremely large values in the Hessian matrix (up to 10^219). + +do iter = 1, maxiter + if (.not. is_finite(sum(abs(d)))) then + d = dold + exit + else + dold = d + end if + if (iter > maxiter) then + exit + end if + + ! Calculate the pivots of the Cholesky factorization of (H + PAR*I), which correspond to the + ! squares of the diagonal entries of L in the Cholesky factorization LL^T, or the diagonal + ! matrix in the LDL factorization. After getting PIV, we can get the LDL factorization of + ! H + PAR*I easily: it is L*diag(PIV)*L^T, where diag(PIV) is the diagonal matrix with PIV being + ! the diagonal, and L is the lower triangular matrix with all the diagonal entries being 1, the + ! subdiagonal being the vector TN/PIV(1:N-1) (entrywise), and all the other entries being 0. + piv = ZERO ! Initialize PIV, so that we know that any NaN in PIV is due to the loop below. + piv(1) = td(1) + par + ! Powell implemented the loop by a GOTO, and K = N when the loop exits. It may not be true here. + do k = 1, n - 1_IK + if (piv(k) > 0) then + piv(k + 1) = td(k + 1) + par - tn(k)**2 / piv(k) + elseif (abs(piv(k)) + abs(tn(k)) <= 0) then ! PIV(K) == 0 == TN(K) + piv(k + 1) = td(k + 1) + par + else ! PIV(K) < 0 .OR. (PIV(K) == 0 .AND. TN(K) /= 0) + exit + end if + end do + + ! Zaikun 20220509 + if (any(is_nan(piv))) then + exit ! Better action to take??? + end if + + ! NEGCRV is TRUE iff H + PAR*I has at least one negative eigenvalue (CRV means curvature). + negcrv = any(piv < 0 .or. (piv <= 0 .and. abs([tn, 0.0_RP]) > 0)) + + ! Handle the case where H + PAR*I is positive semidefinite and the gradient at the trust region + ! center is zero. + if (gsq <= 0 .and. .not. negcrv) then + paru = par + paruest = par + if (par <= 0) then ! PAR == 0. A rare case: the trust region center is optimal. + exit + end if + end if + + if (negcrv) then + ! Set K to the first index corresponding to a negative curvature. + ! N.B.: In theory, we need not prepend N to TRUELOC(...), because TRUELOC must return + ! a nonempty array when NEGCRV is TRUE, and hence K <= N; however, the Fortran code may not + ! behave in this way when compiled with aggressive optimization options; on 20221220, it is + ! observed that K = HUGE(K) = 32767 with Flang -Ofast. + k = minval([n, trueloc(piv < 0 .or. (piv <= 0 .and. abs([tn, 0.0_RP]) > 0))]) + else + ! Set K to the last index corresponding to a zero curvature; K = 0 if no such curvature exits. + k = maxval([0_IK, trueloc(abs(piv) + abs([tn, 0.0_RP]) <= 0)]) + end if + + ! At this point, K == 0 iff H + PAR*I is positive definite. + ! Handle the case where H + PAR*I has at least one nonpositive eigenvalue. + if (k >= 1) then + + ! Set D to a direction of nonpositive curvature of the tridiagonal matrix, and revise PARLEST. + + !------------------------------------------------------------------------------------------! + ! Zaikun 20220512: Powell's code does not include the following initialization. Consequently, + ! D(KSAV+1:N) or D(KSAV+2:N) will not be initialized but inherit values from the previous + ! iteration. Is this intended? + d = ZERO + !------------------------------------------------------------------------------------------! + + d(k) = ONE ! Zaikun 20220512: D(K+1:N) = ? + + !------------------------------------------------------------------------------------------! + ! The code until "Terminate with D set to a multiple of the current D ..." sets only D(1:KSAV) + ! or D(1:KSAV+1), with the KSAV defined later. D_INITIALIZED indicates whether D(1:N) is + ! fully initialized in this process (TRUE) or not (FALSE). See the comments above for details. + !------------------------------------------------------------------------------------------! + + dhd = piv(k) + + ! In Fortran, the following two IFs CANNOT be merged into + ! IF(K < N .AND. ABS(TN(K)) > ABS(PIV(K))). + ! This is because Fortran may not perform a short-circuit evaluation of this logic expression, + ! and hence TN(K) may be accessed even if K >= N, leading to an out-of-boundary index since + ! SIZE(TN) is only N-1. This is not a problem in C, MATLAB, Python, Julia, or R, where short + ! circuit is ensured. + if (k < n) then + if (abs(tn(k)) > abs(piv(k))) then + ! PIV(K+1) was named as "TEMP" in Powell's code. Is PIV(K+1) consistent with the meaning of PIV? + piv(k + 1) = td(k + 1) + par + if (piv(k + 1) <= abs(piv(k))) then + d(k + 1) = sign(ONE, -tn(k)) !!MATLAB: d(k + 1) = -sing(tn(k)) + dhd = piv(k) + piv(k + 1) - TWO * abs(tn(k)) + else + d(k + 1) = -tn(k) / piv(k + 1) + dhd = piv(k) + tn(k) * d(k + 1) + end if + end if + end if + + do i = k - 1_IK, 1, -1 + ! It may happen that TN(I) == 0 == PIV(I). Without checking TN(I), we will get D(I)=NaN. + ! Once we encounter a zero TN(I), D(I) is set to zero, and D(1:I-1) will consequently be + ! zero as well, because D(J) is a multiple of D(J+1) for each J. + if (abs(tn(i)) > 0) then + d(i) = -tn(i) * d(i + 1) / piv(i) + else + d(1:i) = ZERO + exit + end if + end do + + dsq = sum(d**2) + parl = par + parlest = par - dhd / dsq + end if + + if (gsq <= 0 .or. k >= 1) then + ! Handle the case where the gradient at the trust region center is zero or H + PAR*I is not + ! positive definite. + + ! Terminate with D set to a multiple of the current D if the following test suggests so. + if (gsq <= 0) then + partmp = paruest * (ONE - tol) + else + partmp = paruest + end if + if (paruest > 0 .and. parlest >= partmp) then + + !--------------------------------------------------------------------------------------! + ! Zaikun 20220512: + ! The definition of D below requires that D is initialized. In Powell's code, it may + ! happen that only D(1:KSAV) or D(1:KSAV+1) is initialized during the current iteration, + ! but the other entries are inherited from the previous iteration OR from the initial + ! value before the iterations start, which is 0. If such inheriting happens, + ! D_INITIALIZED will be FALSE. In tests on 20220514, both cases did occur. + ! Interestingly, in both cases, the inherited values were all zero or close to zero + ! (1E-16), and hence not very different from the initial value zero that we set above. + ! Is this intended? + !--------------------------------------------------------------------------------------! + + dtg = inprod(d, gg) + if (dtg > 0) then ! Has DSQ got the correct value? + d = -(delta / sqrt(dsq)) * d + else ! This ELSE covers the unlikely yet possible case where DTG is zero or even NaN. + d = (delta / sqrt(dsq)) * d + end if + ! N.B.: As per Powell's code, the lines above would be D = -SIGN(DELTA/SQRT(DSQ), DTG)*D. + ! However, our version here seems more reasonable in case DTG == 0, which is unlikely + ! but did happen numerically. Note that SIGN(A, 0) = |A| /= -SIGN(A, 0). + exit + end if + else + + ! Handle the case where the gradient at the trust region center is nonzero and H + PAR*I + ! is positive definite. + ! Calculate D = -(H + PAR*I)^{-1}*G for the current PAR. The loops below find D using the + ! LDL factorization of the (tridiagonalized) H + PAR*I = L*diag(PIV)*L^T. + d(1) = -gg(1) / piv(1) + ! The loop sets D = -PIV^{-1}L^{-1}*GG + do k = 1, n - 1_IK + d(k + 1) = -(gg(k + 1) + tn(k) * d(k)) / piv(k + 1) + end do + wsq = inprod(piv, d**2) ! GG^T*(H+PAR*I)^{-1}*GG. Needed in the convergence test. + ! The loop sets D = L^{-T}*D = -L^{-T}*PIV^{-1}*L^{-1}*GG = -(H+PAR*I)^{-1}*GG. + do k = n - 1_IK, 1, -1 + d(k) = d(k) - tn(k) * d(k + 1) / piv(k) + end do + + if (.not. is_finite(sum(abs(d)))) then + d = dold + exit + end if + + dsq = sum(d**2) + + ! Return if the Newton-Raphson step is feasible, setting CRVMIN to the least eigenvalue of H. + if (par <= 0 .and. dsq <= delsq) then ! PAR <= 0 indeed means PAR == 0. + crvmin = eigmin(td, tn, 1.0E-2_RP) + !!MATLAB: + !!% It is critical for the efficiency to use `spdiags` to construct `tridh` sparsely. + !!tridh = spdiags([[tn; 0], td, [0; tn]], -1:1, n, n); + !!crvmin = eigs(tridh, 1, 'smallestreal'); + exit + end if + + ! Make the usual test for acceptability of a full trust region step. + dnorm = sqrt(dsq) + + phi = ONE / dnorm - ONE / delta + if (tol * (ONE + par * dsq / wsq) - dsq * phi * phi >= 0) then + d = (delta / dnorm) * d + exit + end if + if (iter >= 2 .and. par <= parl) then + exit + end if + if (paru > 0 .and. par >= paru) then + exit + end if + + ! Complete the iteration when PHI is negative. + if (phi < 0) then + parlest = par + if (posdef) then + if (phi <= phil) then + exit ! Has PHIL got the correct value + end if + slope = (phi - phil) / (par - parl) + parlest = par - phi / slope + end if + if (paru > 0) then + slope = (phiu - phi) / (paru - par) ! Has PHIU got the correct value? + else + slope = ONE / gnorm + end if + partmp = par - phi / slope + if (paruest > 0) then + paruest = min(partmp, paruest) + else + paruest = partmp + end if + posdef = .true. + parl = par + phil = phi + else + + ! If required, calculate Z for the alternative test for convergence. + ! For Z, see the discussions below (16) in Section 2 of the UOBYQA paper (the 2002 version + ! in Math. Program.; in the DAMTP 2000/NA14 report, it is below (2.8) in Section 2). The two + ! loops below find Z using the LDL factorization of the (tridiagonalized) H + PAR*I. + if (.not. posdef) then + z(1) = ONE / piv(1) + do k = 1, n - 1_IK + tnz = tn(k) * z(k) + if (tnz > 0) then + z(k + 1) = -(ONE + tnz) / piv(k + 1) + else + z(k + 1) = (ONE - tnz) / piv(k + 1) + end if + end do + wwsq = inprod(piv, z**2) ! Needed in the convergence test. + do k = n - 1_IK, 1, -1 + z(k) = z(k) - tn(k) * z(k + 1) / piv(k) + end do + + zsq = sum(z**2) + dtz = inprod(d, z) + + ! Apply the alternative test for convergence. + tempa = abs(delsq - dsq) + tempb = sqrt(dtz * dtz + tempa * zsq) + if (abs(dtz) > 0) then + gam = tempa / (sign(tempb, dtz) + dtz) !!MATLAB: gam = tempa / (sign(dtz)*tempb + dtz) + else ! This ELSE covers the unlikely yet possible case where DTZ is zero or even NaN. + gam = sqrt(tempa / zsq) + end if + if (tol * (wsq + par * delsq) - gam * gam * wwsq >= 0) then + d = d + gam * z + exit + end if + parlest = max(parlest, par - wwsq / zsq) + end if + + ! Complete the iteration when PHI is positive. + slope = ONE / gnorm + if (paru > 0) then + if (phi >= phiu) then + exit ! Has PHIU got the correct value? + end if + slope = (phiu - phi) / (paru - par) + end if + parlest = max(parlest, par - phi / slope) + paruest = par + if (posdef) then + slope = (phi - phil) / (par - parl) ! Has PHIL got the correct value? + paruest = par - phi / slope + end if + paru = par + phiu = phi + end if + end if + + ! Pick the value of PAR for the next iteration. + if (paru <= 0) then ! PARU == 0 + par = TWO * parlest + gnorm / delta + else + par = HALF * (parl + paru) + par = max(par, parlest) + end if + if (paruest > 0) par = min(par, paruest) +end do + +! Apply the inverse Householder transformations to recover D. +do k = n - 1_IK, 1, -1 + d(k + 1:n) = d(k + 1:n) - inprod(d(k + 1:n), hh(k + 1:n, k)) * hh(k + 1:n, k) +end do +!!MATLAB: d = P*d; + +! If the More-Sorensen algorithm breaks down abnormally (e.g., NaN in the computation), then ||D|| +! may be (much) more than DELTA. This is handled in the following naive way. +if (norm(d) > delta) then + d = (delta / norm(d)) * d +end if + +! Set CRVMIN to zero if it is NaN, which may happen if the problem is ill-conditioned. +if (is_nan(crvmin)) then + crvmin = ZERO +end if + +! Scale CRVMIN back before return. Note that the trust-region step is scale invariant. +if (scaled .and. crvmin > 0) then + crvmin = crvmin / modscal +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + ! Due to rounding, it may happen that ||D|| > DELTA, but ||D|| > 2*DELTA is highly improbable. + call assert(norm(d) <= TWO * delta, '||D|| <= 2*DELTA', srname) + call assert(crvmin >= 0, 'CRVMIN >= 0', srname) +end if + +end subroutine trstep + + +function trrad(delta_in, dnorm, eta1, eta2, gamma1, gamma2, ratio) result(delta) +!--------------------------------------------------------------------------------------------------! +! This function updates the trust region radius according to RATIO and DNORM. +!--------------------------------------------------------------------------------------------------! + +! Generic module +use, non_intrinsic :: consts_mod, only : RP, DEBUGGING +use, non_intrinsic :: infnan_mod, only : is_nan +use, non_intrinsic :: debug_mod, only : assert + +implicit none + +! Input +real(RP), intent(in) :: delta_in ! Current trust-region radius +real(RP), intent(in) :: dnorm ! Norm of current trust-region step +real(RP), intent(in) :: eta1 ! Ratio threshold for contraction +real(RP), intent(in) :: eta2 ! Ratio threshold for expansion +real(RP), intent(in) :: gamma1 ! Contraction factor +real(RP), intent(in) :: gamma2 ! Expansion factor +real(RP), intent(in) :: ratio ! Reduction ratio + +! Outputs +real(RP) :: delta + +! Local variables +character(len=*), parameter :: srname = 'TRRAD' + +! Preconditions +if (DEBUGGING) then + call assert(delta_in >= dnorm .and. dnorm > 0, 'DELTA_IN >= DNORM > 0', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + ! By the definition of RATIO in ratio.f90, RATIO cannot be NaN unless the actual reduction is + ! NaN, which should NOT happen due to the moderated extreme barrier. + call assert(.not. is_nan(ratio), 'RATIO is not NaN', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +if (ratio <= eta1) then + delta = gamma1 * dnorm ! Powell's UOBYQA/NEWUOA + !delta = gamma1 * delta_in ! Powell's COBYLA/LINCOA. + !delta = min(gamma1 * delta_in, dnorm) ! Powell's BOBYQA. +else if (ratio <= eta2) then + delta = max(gamma1 * delta_in, dnorm) ! Powell's UOBYQA/NEWUOA/BOBYQA/LINCOA +else + delta = max(gamma1 * delta_in, gamma2 * dnorm) ! Powell's NEWUOA/BOBYQA. Works well for UOBYQA. + !delta = max(delta_in, 1.25_RP * dnorm, dnorm + rho) ! Powell's original UOBYQA code. + !delta = max(delta_in, gamma2 * dnorm) ! This works evidently better than Powell's version. + !delta = min(max(gamma1 * delta_in, gamma2 * dnorm), sqrt(gamma2) * delta_in) ! Powell's LINCOA. +end if + +! For noisy problems, the following may work better. +! !if (ratio <= eta1) then +! ! delta = gamma1 * dnorm +! !elseif (ratio <= eta2) then ! Ensure DELTA >= DELTA_IN +! ! delta = delta_in +! !else ! Ensure DELTA > DELTA_IN with a constant factor +! ! delta = max(delta_in * (1.0_RP + gamma2) / 2.0_RP, gamma2 * dnorm) +! !end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(delta > 0, 'DELTA > 0', srname) +end if + +end function trrad + + +end module trustregion_uobyqa_mod diff --git a/examples/fortran/prima/native/uobyqa/uobyqa.f90 b/examples/fortran/prima/native/uobyqa/uobyqa.f90 new file mode 100644 index 000000000..2c116827f --- /dev/null +++ b/examples/fortran/prima/native/uobyqa/uobyqa.f90 @@ -0,0 +1,407 @@ +module uobyqa_mod +!--------------------------------------------------------------------------------------------------! +! UOBYQA_MOD is a module providing the reference implementation of Powell's UOBYQA algorithm in +! +! M. J. D. Powell, UOBYQA: unconstrained optimization by quadratic approximation, Math. Program., +! 92(B):555--582, 2002 +! +! UOBYQA approximately solves +! +! min F(X), +! +! where X is a vector of variables that has N components and F is a real-valued objective function. +! It tackles the problem by a trust region method that forms quadratic models by interpolation. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on the UOBYQA paper and Powell's code, with +! modernization, bug fixes, and improvements. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Wed 10 Sep 2025 02:03:43 AM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: uobyqa + + +contains + + +subroutine uobyqa(calfun, x, & + & f, nf, rhobeg, rhoend, ftarget, maxfun, iprint, eta1, eta2, gamma1, gamma2, & + & xhist, fhist, maxhist, callback_fcn, info) +!--------------------------------------------------------------------------------------------------! +! Among all the arguments, only CALFUN and X are obligatory. The others are OPTIONAL and you can +! neglect them unless you are familiar with the algorithm. Any unspecified optional input will take +! the default value detailed below. For instance, we may invoke the solver as follows. +! +! ! First define CALFUN and X, and then do the following. +! call uobyqa(calfun, x, f) +! +! or +! +! ! First define CALFUN and X, and then do the following. +! call uobyqa(calfun, x, f, rhobeg = 1.0D0, rhoend = 1.0D-6) +! +! See examples/uobyqa_exmp.f90 for a concrete example. +! +! A detailed introduction to the arguments is as follows. +! N.B.: RP and IK are defined in the module CONSTS_MOD. See consts.F90 under the directory name +! "common". By default, RP = kind(0.0D0) and IK = kind(0), with REAL(RP) being the double-precision +! real, and INTEGER(IK) being the default integer. For ADVANCED USERS, RP and IK can be defined by +! setting PRIMA_REAL_PRECISION and PRIMA_INTEGER_KIND in common/ppf.h. Use the default if unsure. +! +! CALFUN +! Input, subroutine. +! CALFUN(X, F) should evaluate the objective function at the given REAL(RP) vector X and set the +! value to the REAL(RP) scalar F. It must be provided by the user, and its definition must conform +! to the following interface: +! !-------------------------------------------------------------------------! +! subroutine calfun(x, f) +! real(RP), intent(in) :: x(:) +! real(RP), intent(out) :: f +! end subroutine calfun +! !-------------------------------------------------------------------------! +! +! X +! Input and output, REAL(RP) vector. +! As an input, X should be an N dimensional vector that contains the starting point, N being the +! dimension of the problem. As an output, X will be set to an approximate minimizer. +! +! F +! Output, REAL(RP) scalar. +! F will be set to the objective function value of X at exit. +! +! NF +! Output, INTEGER(IK) scalar. +! NF will be set to the number of calls of CALFUN at exit. +! +! RHOBEG, RHOEND +! Inputs, REAL(RP) scalars, default: RHOBEG = 1, RHOEND = 10^-6. RHOBEG and RHOEND must be set to +! the initial and final values of a trust-region radius, both being positive and RHOEND <= RHOBEG. +! Typically RHOBEG should be about one tenth of the greatest expected change to a variable, and +! RHOEND should indicate the accuracy that is required in the final values of the variables. +! +! FTARGET +! Input, REAL(RP) scalar, default: -Inf. +! FTARGET is the target function value. The algorithm will terminate when a point with a function +! value <= FTARGET is found. +! +! MAXFUN +! Input, INTEGER(IK) scalar, default: MAXFUN_DIM_DFT*N with MAXFUN_DIM_DFT defined in the module +! CONSTS_MOD (see common/consts.F90). MAXFUN is the maximal number of calls of CALFUN. +! +! IPRINT +! Input, INTEGER(IK) scalar, default: 0. +! The value of IPRINT should be set to 0, 1, -1, 2, -2, 3, or -3, which controls how much +! information will be printed during the computation: +! 0: there will be no printing; +! 1: a message will be printed to the screen at the return, showing the best vector of variables +! found and its objective function value; +! 2: in addition to 1, each new value of RHO is printed to the screen, with the best vector of +! variables so far and its objective function value; +! 3: in addition to 2, each function evaluation with its variables will be printed to the screen; +! -1, -2, -3: the same information as 1, 2, 3 will be printed, not to the screen but to a file +! named UOBYQA_output.txt; the file will be created if it does not exist; the new output will +! be appended to the end of this file if it already exists. +! Note that IPRINT = +/-3 can be costly in terms of time and/or space. +! +! ETA1, ETA2, GAMMA1, GAMMA2 +! Input, REAL(RP) scalars, default: ETA1 = 0.1, ETA2 = 0.7, GAMMA1 = 0.5, and GAMMA2 = 2. +! ETA1, ETA2, GAMMA1, and GAMMA2 are parameters in the updating scheme of the trust-region radius +! detailed in the subroutine TRRAD in trustregion.f90. Roughly speaking, the trust-region radius +! is contracted by a factor of GAMMA1 when the reduction ratio is below ETA1, and enlarged by a +! factor of GAMMA2 when the reduction ratio is above ETA2. It is required that 0 < ETA1 <= ETA2 +! < 1 and 0 < GAMMA1 < 1 < GAMMA2. Normally, ETA1 <= 0.25. It is NOT advised to set ETA1 >= 0.5. +! +! XHIST, FHIST, MAXHIST +! XHIST: Output, ALLOCATABLE rank 2 REAL(RP) array; +! FHIST: Output, ALLOCATABLE rank 1 REAL(RP) array; +! MAXHIST: Input, INTEGER(IK) scalar, default: MAXFUN +! XHIST, if present, will output the history of iterates, while FHIST, if present, will output the +! history function values. MAXHIST should be a nonnegative integer, and XHIST/FHIST will output +! only the history of the last MAXHIST iterations. Therefore, MAXHIST = 0 means XHIST/FHIST will +! output nothing, while setting MAXHIST = MAXFUN requests XHIST/FHIST to output all the history. +! If XHIST is present, its size at exit will be (N, min(NF, MAXHIST)); if FHIST is present, its +! size at exit will be min(NF, MAXHIST). +! +! IMPORTANT NOTICE: +! Setting MAXHIST to a large value can be costly in terms of memory for large problems. +! MAXHIST will be reset to a smaller value if the memory needed exceeds MAXHISTMEM defined in +! CONSTS_MOD (see consts.F90 under the directory named "common"). +! Use *HIST with caution!!! (N.B.: the algorithm is NOT designed for large problems). +! +! CALLBACK_FCN +! Input, function to report progress and optionally request termination. +! +! INFO +! Output, INTEGER(IK) scalar. +! INFO is the exit flag. It will be set to one of the following values defined in the module +! INFOS_MOD (see common/infos.f90): +! SMALL_TR_RADIUS: the lower bound for the trust region radius is reached; +! FTARGET_ACHIEVED: the target function value is reached; +! MAXFUN_REACHED: the objective function has been evaluated MAXFUN times; +! MAXTR_REACHED: the trust region iteration has been performed MAXTR times (MAXTR = 2*MAXFUN); +! NAN_INF_MODEL: NaN or Inf occurs in the model; +! NAN_INF_X: NaN or Inf occurs in X. +! !--------------------------------------------------------------------------! +! The following case(s) should NEVER occur unless there is a bug. +! NAN_INF_F: the objective function returns NaN or +Inf; +! TRSUBP_FAILED: a trust region step has failed to reduce the model; +! !--------------------------------------------------------------------------! +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : DEBUGGING +use, non_intrinsic :: consts_mod, only : MAXFUN_DIM_DFT +use, non_intrinsic :: consts_mod, only : RHOBEG_DFT, RHOEND_DFT, FTARGET_DFT, IPRINT_DFT +use, non_intrinsic :: consts_mod, only : RP, IK, TWO, HALF, TEN, TENTH, EPS +use, non_intrinsic :: debug_mod, only : assert, warning, validate +use, non_intrinsic :: evaluate_mod, only : moderatex +use, non_intrinsic :: history_mod, only : prehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_finite, is_posinf +use, non_intrinsic :: memory_mod, only : safealloc +use, non_intrinsic :: pintrf_mod, only : OBJ, CALLBACK +use, non_intrinsic :: preproc_mod, only : preproc +use, non_intrinsic :: string_mod, only : num2str + +! Solver-specific modules +use, non_intrinsic :: uobyqb_mod, only : uobyqb + +implicit none + +! Compulsory arguments +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +real(RP), intent(inout) :: x(:) ! X(N) + +! Optional inputs +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in), optional :: iprint +integer(IK), intent(in), optional :: maxfun +integer(IK), intent(in), optional :: maxhist +real(RP), intent(in), optional :: eta1 +real(RP), intent(in), optional :: eta2 +real(RP), intent(in), optional :: ftarget +real(RP), intent(in), optional :: gamma1 +real(RP), intent(in), optional :: gamma2 +real(RP), intent(in), optional :: rhobeg +real(RP), intent(in), optional :: rhoend + +! Optional outputs +integer(IK), intent(out), optional :: info +integer(IK), intent(out), optional :: nf +real(RP), intent(out), optional :: f +real(RP), intent(out), optional, allocatable :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out), optional, allocatable :: xhist(:, :) ! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'UOBYQA' +character(len=*), parameter :: srname = 'UOBYQA' +integer(IK) :: info_loc +integer(IK) :: iprint_loc +integer(IK) :: maxfun_loc +integer(IK) :: maxhist_loc +integer(IK) :: n +integer(IK) :: nf_loc +integer(IK) :: nhist +integer(IK) :: npt +real(RP) :: eta1_loc +real(RP) :: eta2_loc +real(RP) :: f_loc +real(RP) :: ftarget_loc +real(RP) :: gamma1_loc +real(RP) :: gamma2_loc +real(RP) :: rhobeg_loc +real(RP) :: rhoend_loc +real(RP), allocatable :: fhist_loc(:) ! FHIST_LOC(MAXFHIST) +real(RP), allocatable :: xhist_loc(:, :) ! XHIST_LOC(N, MAXXHIST) + + +! Sizes +n = int(size(x), kind(n)) +npt = (n + 1_IK) * (n + 2_IK) / 2_IK +call validate(npt > 0, 'NPT > 0', srname) ! Validate that NPT does not overflow. + +! Replace any NaN in X by ZERO and Inf/-Inf in X by REALMAX/-REALMAX. +x = moderatex(x) + +! Read the inputs. + +! If RHOBEG is present, then RHOBEG_LOC is a copy of RHOBEG; otherwise, RHOBEG_LOC takes the default +! value for RHOBEG, taking the value of RHOEND into account. Note that RHOEND is considered only if +! it is present and it is VALID (i.e., finite and positive). The other inputs are read similarly. +if (present(rhobeg)) then + rhobeg_loc = rhobeg +elseif (present(rhoend)) then + ! Fortran does not take short-circuit evaluation of logic expressions. Thus it is WRONG to + ! combine the evaluation of PRESENT(RHOEND) and the evaluation of IS_FINITE(RHOEND) as + ! "IF (PRESENT(RHOEND) .AND. IS_FINITE(RHOEND))". The compiler may choose to evaluate the + ! IS_FINITE(RHOEND) even if PRESENT(RHOEND) is false! + if (is_finite(rhoend) .and. rhoend > 0) then + rhobeg_loc = max(TEN * rhoend, RHOBEG_DFT) + else + rhobeg_loc = RHOBEG_DFT + end if +else + rhobeg_loc = RHOBEG_DFT +end if + +if (present(rhoend)) then + rhoend_loc = rhoend +elseif (rhobeg_loc > 0) then + rhoend_loc = max(EPS, min((RHOEND_DFT / RHOBEG_DFT) * rhobeg_loc, RHOEND_DFT)) +else + rhoend_loc = RHOEND_DFT +end if + +if (present(ftarget)) then + ftarget_loc = ftarget +else + ftarget_loc = FTARGET_DFT +end if + +if (present(maxfun)) then + maxfun_loc = maxfun +else + maxfun_loc = max(MAXFUN_DIM_DFT * n, npt + 1_IK) +end if + +if (present(iprint)) then + iprint_loc = iprint +else + iprint_loc = IPRINT_DFT +end if + +if (present(eta1)) then + eta1_loc = eta1 +elseif (present(eta2)) then + if (eta2 > 0 .and. eta2 < 1) then + eta1_loc = max(EPS, eta2 / 7.0_RP) + end if +else + eta1_loc = TENTH +end if + +if (present(eta2)) then + eta2_loc = eta2 +elseif (eta1_loc > 0 .and. eta1_loc < 1) then + eta2_loc = (eta1_loc + TWO) / 3.0_RP +else + eta2_loc = 0.7_RP +end if + +if (present(gamma1)) then + gamma1_loc = gamma1 +else + gamma1_loc = HALF +end if + +if (present(gamma2)) then + gamma2_loc = gamma2 +else + gamma2_loc = TWO +end if + +if (present(maxhist)) then + maxhist_loc = maxhist +else + maxhist_loc = maxval([maxfun_loc, npt + 1_IK, MAXFUN_DIM_DFT * n]) +end if + +! Preprocess the inputs in case some of them are invalid. +call preproc(solver, n, iprint_loc, maxfun_loc, maxhist_loc, ftarget_loc, rhobeg_loc, rhoend_loc, & + & eta1=eta1_loc, eta2=eta2_loc, gamma1=gamma1_loc, gamma2=gamma2_loc) + +! Further revise MAXHIST_LOC according to MAXHISTMEM, and allocate memory for the history. +! In MATLAB/Python/Julia/R implementation, we should simply set MAXHIST = MAXFUN and initialize +! FHIST = NaN(1, MAXFUN), XHIST = NaN(N, MAXFUN) if they are requested; replace MAXFUN with 0 for +! the history that is not requested. +call prehist(maxhist_loc, n, present(xhist), xhist_loc, present(fhist), fhist_loc) + + +!-------------------- Call UOBYQB, which performs the real calculations. --------------------------! +if (present(callback_fcn)) then + call uobyqb(calfun, iprint_loc, maxfun_loc, eta1_loc, eta2_loc, ftarget_loc, gamma1_loc, & + & gamma2_loc, rhobeg_loc, rhoend_loc, x, nf_loc, f_loc, fhist_loc, xhist_loc, info_loc, callback_fcn) +else + call uobyqb(calfun, iprint_loc, maxfun_loc, eta1_loc, eta2_loc, ftarget_loc, gamma1_loc, & + & gamma2_loc, rhobeg_loc, rhoend_loc, x, nf_loc, f_loc, fhist_loc, xhist_loc, info_loc) +end if +!--------------------------------------------------------------------------------------------------! + + +! Write the outputs. + +if (present(f)) then + f = f_loc +end if + +if (present(nf)) then + nf = nf_loc +end if + +if (present(info)) then + info = info_loc +end if + +! Copy XHIST_LOC to XHIST if needed. +if (present(xhist)) then + nhist = min(nf_loc, int(size(xhist_loc, 2), IK)) + !----------------------------------------------------! + call safealloc(xhist, n, nhist) ! Removable in F2003. + !----------------------------------------------------! + xhist = xhist_loc(:, 1:nhist) + ! N.B.: + ! 0. Allocate XHIST as long as it is present, even if the size is 0; otherwise, it will be + ! illegal to enquire XHIST after exit. + ! 1. Even though Fortran 2003 supports automatic (re)allocation of allocatable arrays upon + ! intrinsic assignment, we keep the line of SAFEALLOC, because some very new compilers (Absoft + ! Fortran 21.0) are still not standard-compliant in this respect. + ! 2. NF may not be present. Hence we should NOT use NF but NF_LOC. + ! 3. When SIZE(XHIST_LOC, 2) > NF_LOC, which is the normal case in practice, XHIST_LOC contains + ! GARBAGE in XHIST_LOC(:, NF_LOC + 1 : END). Therefore, we MUST cap XHIST at NF_LOC so that + ! XHIST contains only valid history. For this reason, there is no way to avoid allocating + ! two copies of memory for XHIST unless we declare it to be a POINTER instead of ALLOCATABLE. +end if +! F2003 automatically deallocate local ALLOCATABLE variables at exit, yet we prefer to deallocate +! them immediately when they finish their jobs. +deallocate (xhist_loc) + +! Copy FHIST_LOC to FHIST if needed. +if (present(fhist)) then + nhist = min(nf_loc, int(size(fhist_loc), IK)) + !--------------------------------------------------! + call safealloc(fhist, nhist) ! Removable in F2003. + !--------------------------------------------------! + fhist = fhist_loc(1:nhist) ! The same as XHIST, we must cap FHIST at NF_LOC. +end if +deallocate (fhist_loc) + +! If MAXFHIST_IN >= NF_LOC > MAXFHIST_LOC, warn that not all history is recorded. +if ((present(xhist) .or. present(fhist)) .and. maxhist_loc < nf_loc) then + call warning(solver, 'Only the history of the last '//num2str(maxhist_loc)//' function evaluation(s) is recorded') +end if + +! Postconditions +if (DEBUGGING) then + call assert(nf_loc <= maxfun_loc, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + nhist = min(nf_loc, maxhist_loc) + if (present(xhist)) then + call assert(size(xhist, 1) == n .and. size(xhist, 2) == nhist, 'SIZE(XHIST) == [N, NHIST]', srname) + call assert(.not. any(is_nan(xhist)), 'XHIST does not contain NaN', srname) + end if + if (present(fhist)) then + call assert(size(fhist) == nhist, 'SIZE(FHIST) == NHIST', srname) + call assert(.not. any(is_nan(fhist) .or. is_posinf(fhist)), 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(fhist < f_loc), 'F is the smallest in FHIST', srname) + end if +end if + +end subroutine uobyqa + + +end module uobyqa_mod diff --git a/examples/fortran/prima/native/uobyqa/uobyqb.f90 b/examples/fortran/prima/native/uobyqa/uobyqb.f90 new file mode 100644 index 000000000..2d8eeed04 --- /dev/null +++ b/examples/fortran/prima/native/uobyqa/uobyqb.f90 @@ -0,0 +1,600 @@ +module uobyqb_mod +!--------------------------------------------------------------------------------------------------! +! This module performs the major calculations of UOBYQA. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the UOBYQA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: February 2022 +! +! Last Modified: Wed 08 Apr 2026 06:39:00 PM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: uobyqb + + +contains + + +subroutine uobyqb(calfun, iprint, maxfun, eta1, eta2, ftarget, gamma1, gamma2, rhobeg, rhoend, & + & x, nf, f, fhist, xhist, info, callback_fcn) +!--------------------------------------------------------------------------------------------------! +! This subroutine performs the major calculations of UOBYQA. +! +! The arguments N, X, RHOBEG, RHOEND, IPRINT and MAXFUN are identical to the corresponding arguments +! in subroutine UOBYQA. +! +! XBASE will contain a shift of origin that reduces the contributions from rounding errors to values +! of the model and Lagrange functions. +! XBASE holds a shift of origin that should reduce the contributions from rounding errors to values +! of the model and Lagrange functions. +! XOPT is the displacement from XBASE of the best vector of variables so far (i.e., the one provides +! the least calculated F so far). FOPT = F(XOPT + XBASE). However, we do not save XOPT and FOPT +! explicitly, because XOPT = XPT(:, KOPT) and FOPT = FVAL(KOPT), which is explained below. +! [XPT, FVAL, KOPT] describes the interpolation set: +! XPT contains the interpolation points relative to XBASE, each COLUMN for a point; FVAL holds the +! values of F at the interpolation points; KOPT is the index of XOPT in XPT. +! PQ will contain the parameters of the quadratic model. +! PL will contain the parameters of the Lagrange functions. +! D is reserved for trial steps from XOPT. It is chosen by subroutine TRSTEP or GEOSTEP. Usually +! XBASE + XOPT + D is the vector of variables for the next call of CALFUN. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: checkexit_mod, only : checkexit +use, non_intrinsic :: consts_mod, only : RP, IK, ZERO, ONE, HALF, TENTH, REALMAX, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert, validate +use, non_intrinsic :: evaluate_mod, only : evaluate +use, non_intrinsic :: history_mod, only : savehist, rangehist +use, non_intrinsic :: infnan_mod, only : is_nan, is_posinf, is_finite +use, non_intrinsic :: infos_mod, only : INFO_DFT, SMALL_TR_RADIUS, MAXTR_REACHED, CALLBACK_TERMINATE, NAN_INF_MODEL +use, non_intrinsic :: linalg_mod, only : vec2smat, smat_mul_vec, norm +use, non_intrinsic :: memory_mod, only : safealloc +use, non_intrinsic :: message_mod, only : fmsg, rhomsg, retmsg +use, non_intrinsic :: pintrf_mod, only : OBJ, CALLBACK +use, non_intrinsic :: powalg_mod, only : quadinc +use, non_intrinsic :: ratio_mod, only : redrat +use, non_intrinsic :: redrho_mod, only : redrho +use, non_intrinsic :: shiftbase_mod, only : shiftbase + +! Solver-specific modules +use, non_intrinsic :: geometry_uobyqa_mod, only : geostep, setdrop_tr +use, non_intrinsic :: initialize_uobyqa_mod, only : initxf, initq, initl +use, non_intrinsic :: trustregion_uobyqa_mod, only : trstep, trrad +use, non_intrinsic :: update_uobyqa_mod, only : update + +implicit none + +! Inputs +procedure(OBJ) :: calfun ! N.B.: INTENT cannot be specified if a dummy procedure is not a POINTER +procedure(CALLBACK), optional :: callback_fcn +integer(IK), intent(in) :: iprint +integer(IK), intent(in) :: maxfun +real(RP), intent(in) :: eta1 +real(RP), intent(in) :: eta2 +real(RP), intent(in) :: ftarget +real(RP), intent(in) :: gamma1 +real(RP), intent(in) :: gamma2 +real(RP), intent(in) :: rhobeg +real(RP), intent(in) :: rhoend + +! In-outputs +real(RP), intent(inout) :: x(:) ! X(N) + +! Outputs +integer(IK), intent(out) :: info +integer(IK), intent(out) :: nf +real(RP), intent(out) :: f +real(RP), intent(out) :: fhist(:) ! FHIST(MAXFHIST) +real(RP), intent(out) :: xhist(:, :) ! XHIST(N, MAXXHIST) + +! Local variables +character(len=*), parameter :: solver = 'UOBYQA' +character(len=*), parameter :: srname = 'UOBYQB' +integer(IK) :: k +integer(IK) :: knew_geo +integer(IK) :: knew_tr +integer(IK) :: kopt +integer(IK) :: maxfhist +integer(IK) :: maxhist +integer(IK) :: maxtr +integer(IK) :: maxxhist +integer(IK) :: n +integer(IK) :: npt +integer(IK) :: subinfo +integer(IK) :: tr +logical :: accurate_mod +logical :: adequate_geo +logical :: bad_trstep +logical :: close_itpset +logical :: improve_geo +logical :: reduce_rho +logical :: shortd +logical :: small_trrad +logical :: terminate +logical :: trfail +logical :: ximproved +real(RP) :: crvmin +real(RP) :: d(size(x)) +real(RP) :: ddmove +real(RP) :: delbar +real(RP) :: delta +real(RP) :: distsq((size(x) + 1) * (size(x) + 2) / 2) +real(RP) :: dnorm +real(RP) :: dnorm_rec(2) ! Powell's implementation: DNORM_REC(3) +real(RP) :: fval(size(distsq)) +real(RP) :: g(size(x)) +real(RP) :: gamma3 +real(RP) :: h(size(x), size(x)) +real(RP) :: moderr +real(RP) :: moderr_rec(size(dnorm_rec)) +real(RP) :: pq(size(distsq) - 1) +real(RP) :: qred +real(RP) :: ratio +real(RP) :: rho +real(RP) :: xbase(size(x)) +real(RP) :: xdrop(size(x)) +real(RP) :: xpt(size(x), size(distsq)) +real(RP), allocatable :: pl(:, :) +real(RP), parameter :: trtol = 1.0E-2_RP ! Convergence tolerance of trust-region subproblem solver + +! Sizes. +n = int(size(x), kind(n)) +npt = (n + 1_IK) * (n + 2_IK) / 2_IK +call validate(npt > 0, 'NPT > 0', srname) ! Validate that NPT does not overflow. +maxxhist = int(size(xhist, 2), kind(maxxhist)) +maxfhist = int(size(fhist), kind(maxfhist)) +maxhist = max(maxxhist, maxfhist) + +! Preconditions. +if (DEBUGGING) then + call assert(abs(iprint) <= 3, 'IPRINT is 0, 1, -1, 2, -2, 3, or -3', srname) + call assert(n >= 1, 'N >= 1', srname) + call assert(maxfun >= npt + 1, 'MAXFUN >= NPT + 1', srname) + call assert(rhobeg >= rhoend .and. rhoend > 0, 'RHOBEG >= RHOEND > 0', srname) + call assert(all(is_finite(x)), 'X is finite', srname) + call assert(eta1 >= 0 .and. eta1 <= eta2 .and. eta2 < 1, '0 <= ETA1 <= ETA2 < 1', srname) + call assert(gamma1 > 0 .and. gamma1 < 1 .and. gamma2 > 1, '0 < GAMMA1 < 1 < GAMMA2', srname) + call assert(maxhist >= 0 .and. maxhist <= maxfun, '0 <= MAXHIST <= MAXFUN', srname) + call assert(maxfhist * (maxfhist - maxhist) == 0, 'SIZE(FHIST) == 0 or MAXHIST', srname) + call assert(size(xhist, 1) == n .and. maxxhist * (maxxhist - maxhist) == 0, & + & 'SIZE(XHIST, 1) == N, SIZE(XHIST, 2) == 0 or MAXHIST', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Initialize XBASE, XPT, FVAL, and KOPT, together with the history and NF. +call initxf(calfun, iprint, maxfun, ftarget, rhobeg, x, kopt, nf, fhist, fval, xbase, xhist, xpt, subinfo) + +! Report the current best value, and check if user asks for early termination. +terminate = .false. +if (present(callback_fcn)) then + call callback_fcn(xbase + xpt(:, kopt), fval(kopt), nf, 0_IK, terminate=terminate) + if (terminate) then + subinfo = CALLBACK_TERMINATE + end if +end if + +! Initialize X and F according to KOPT. +x = xbase + xpt(:, kopt) +f = fval(kopt) + +! Finish the initialization if INITXF completed normally and CALLBACK did not request termination; +! otherwise, do not proceed, as XPT etc may be uninitialized, leading to errors or exceptions. +if (subinfo == INFO_DFT) then + ! Initialize the Lagrange polynomials represented by PL. Allocate memory for it first. In + ! general, to make the implementation simple and straightforward, we use automatic arrays rather + ! than allocable ones whenever possible. However, PL is an exception, as its size is O(N^4). If + ! SAFEALLOC fails, an informative error will be raised, which is preferred to a silent or + ! ambiguous failure. + call safealloc(pl, npt - 1_IK, npt) + call initl(xpt, pl) + + ! Initialize the quadratic model represented by PQ. + call initq(fval, xpt, pq) + if (.not. (all(is_finite(pq)))) then + subinfo = NAN_INF_MODEL + end if +end if + +! Check whether to return due to abnormal cases that may occur during the initialization. +if (subinfo /= INFO_DFT) then + info = subinfo + ! Arrange FHIST and XHIST so that they are in the chronological order. + call rangehist(nf, xhist, fhist) + ! Print a return message according to IPRINT. + call retmsg(solver, info, iprint, nf, f, x) + ! Postconditions + if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(fhist(1:min(nf, maxfhist)) < f), 'F is the smallest in FHIST', srname) + end if + return +end if + +! Set some more initial values. +! We must initialize RATIO. Otherwise, when SHORTD = TRUE, compilers may raise a run-time error that +! RATIO is undefined. But its value will not be used: when SHORTD = FALSE, its value will be +! overwritten; when SHORTD = TRUE, its value is used only in BAD_TRSTEP, which is TRUE regardless of +! RATIO. Similar for KNEW_TR. +! No need to initialize SHORTD unless MAXTR < 1, but some compilers may complain if we do not do it. +rho = rhobeg +delta = rho +shortd = .false. +trfail = .false. +ratio = -ONE +ddmove = -ONE +dnorm_rec = REALMAX +moderr_rec = REALMAX +knew_tr = 0 +knew_geo = 0 + +! If DELTA <= GAMMA3*RHO after an update, we set DELTA to RHO. GAMMA3 must be less than GAMMA2. The +! reason is as follows. Imagine a very successful step with DENORM = the un-updated DELTA = RHO. +! Then TRRAD will update DELTA to GAMMA2*RHO. If GAMMA3 >= GAMMA2, then DELTA will be reset to RHO, +! which is not reasonable as D is very successful. See paragraph two of Sec. 5.2.5 in +! T. M. Ragonneau's thesis: "Model-Based Derivative-Free Optimization Methods and Software". +! According to test on 20230613, for UOBYQA, this Powellful updating scheme of DELTA works better +! than setting directly DELTA = MAX(NEW_DELTA, RHO). +gamma3 = max(ONE, min(0.75_RP * gamma2, 1.5_RP)) + +! MAXTR is the maximal number of trust-region iterations. Here, we set it to HUGE(MAXTR) - 1 so that +! the algorithm will not terminate due to MAXTR. However, this may not be allowed in other languages +! such as MATLAB. In that case, we can set MAXTR to 10*MAXFUN, which is unlikely to reach because +! each trust-region iteration takes 1 or 2 function evaluations unless the trust-region step is short +! or fails to reduce the trust-region model but the geometry step is not invoked. +! N.B.: Do NOT set MAXTR to HUGE(MAXTR), as it may cause overflow and infinite cycling in the DO +! loop. See +! https://fortran-lang.discourse.group/t/loop-variable-reaching-integer-huge-causes-infinite-loop +! https://fortran-lang.discourse.group/t/loops-dont-behave-like-they-should +maxtr = huge(maxtr) - 1_IK !!MATLAB: maxtr = 10 * maxfun; +info = MAXTR_REACHED + +! Begin the iterative procedure. +! After solving a trust-region subproblem, we use three boolean variables to control the workflow. +! SHORTD: Is the trust-region trial step too short to invoke a function evaluation? +! IMPROVE_GEO: Should we improve the geometry? +! REDUCE_RHO: Should we reduce rho? +! UOBYQA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. +do tr = 1, maxtr + ! CLOSE_ITPSET: Are the interpolation points close to XOPT? It affects IMPROVE_GEO, REDUCE_RHO. + ! N.B. (Zaikun 20240331): In Powell's algorithms, CLOSE_ITPSET is defined after XPT is updated + ! according to the trust-region trial step. + distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - xpt(:, kopt)).^2) % Implicit expansion + close_itpset = all(distsq <= 4.0_RP * delta**2) ! Powell's NEWUOA code. + ! Below are some alternative definitions of CLOSE_ITPSET. + ! N.B.: The threshold for CLOSE_ITPSET is at least DELBAR, the trust region radius for GEOSTEP. + ! !close_itpset = all(distsq <= 4.0_RP * rho**2) ! Powell's code. + ! !close_itpset = all(distsq <= max((TWO * delta)**2, (TEN * rho)**2)) ! Powell's BOBYQA code. + ! !close_itpset = all(distsq <= max(delta**2, 4.0_RP * rho**2)) ! Powell's LINCOA code. + + ! Generate trust region step D, and also calculate a lower bound on the Hessian of Q. + g = pq(1:n) + smat_mul_vec(pq(n + 1:npt - 1), xpt(:, kopt)) + h = vec2smat(pq(n + 1:npt - 1)) + call trstep(delta, g, h, trtol, d, crvmin) + dnorm = min(delta, norm(d)) + + ! Check whether D is too short to invoke a function evaluation. + shortd = (dnorm <= HALF * rho) ! `<=` works better than `<` in case of underflow. + + ! Set QRED to the reduction of the quadratic model when the move D is made from XOPT. QRED + ! should be positive. If it is nonpositive due to rounding errors, we will not take this step. + qred = -quadinc(pq, d, xpt(:, kopt)) ! QRED = Q(XOPT) - Q(XOPT + D) + trfail = (.not. qred > 1.0E-6 * rho**2) ! QRED is tiny/negative or NaN. + + if (shortd .or. trfail) then + ! Powell's code does not reduce DELTA as follows. This comes from NEWUOA and works well. + delta = TENTH * delta + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + else + ! Calculate the next value of the objective function. + ! If X is close to one of the points in the interpolation set, then we do not evaluate the + ! objective function X, assuming it to have the value at the closest point. + x = xbase + (xpt(:, kopt) + d) + distsq = [(sum((x - (xbase + xpt(:, k)))**2, dim=1), k=1, npt)] ! Implied do-loop + !!MATLAB: distsq = sum((x - (xbase + xpt))**2, 1) % Implicit expansion + k = int(minloc(distsq, dim=1), kind(k)) + if (distsq(k) <= (1.0E-4 * rhoend)**2) then + f = fval(k) + else + ! Evaluate the objective function at X, taking care of possible Inf/NaN values. + call evaluate(calfun, x, f) + nf = nf + 1_IK + ! Save X and F into the history. + call savehist(nf, x, xhist, f, fhist) + end if + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Trust region', iprint, nf, delta, f, x) + + ! Update DNORM_REC and MODERR_REC. + ! DNORM_REC records the DNORM of the recent function evaluations with the current RHO. + dnorm_rec = [dnorm_rec(2:size(dnorm_rec)), dnorm] + ! MODERR is the error of the current model in predicting the change in F due to D. + ! MODERR_REC records the prediction errors of the recent models with the current RHO. + moderr = f - fval(kopt) + qred + moderr_rec = [moderr_rec(2:size(moderr_rec)), moderr] + + ! Calculate the reduction ratio by REDRAT, which handles Inf/NaN carefully. + ratio = redrat(fval(kopt) - f, qred, eta1) + + ! Update DELTA. After this, DELTA < DNORM may hold. + delta = trrad(delta, dnorm, eta1, eta2, gamma1, gamma2, ratio) + if (delta <= gamma3 * rho) then + delta = rho ! Set DELTA to RHO when it is close to or below. + end if + + ! Is the newly generated X better than current best point? + ximproved = (f < fval(kopt)) + + ! Set KNEW to the index of the next interpolation point to be deleted. + knew_tr = setdrop_tr(kopt, ximproved, d, pl, rho, xpt) + + ! DDMOVE is norm square of DMOVE in the UOBYQA paper. See Steps 6--7 in Sec. 5 of the paper. + ddmove = ZERO + if (knew_tr > 0) then + xdrop = xpt(:, knew_tr) + ! Update PL, PQ, XPT, FVAL, and KOPT so that XPT(:, KNEW_TR) becomes XOPT + D. + call update(knew_tr, d, f, moderr, kopt, fval, pl, pq, xpt) + if (.not. (all(is_finite(pq)))) then + info = NAN_INF_MODEL + exit + end if + ddmove = sum((xdrop - xpt(:, kopt))**2) ! KOPT is updated. + end if + + ! Check whether to exit + subinfo = checkexit(maxfun, nf, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + end if ! End of IF (SHORTD .OR. TRFAIL). The normal trust-region calculation ends. + + + !----------------------------------------------------------------------------------------------! + ! Before the next trust-region iteration, we may improve the geometry of XPT or reduce RHO + ! according to IMPROVE_GEO and REDUCE_RHO, which in turn depend on the following indicators. + ! N.B.: We must ensure that the algorithm does not set IMPROVE_GEO = TRUE at infinitely many + ! consecutive iterations without moving XOPT or reducing RHO. Otherwise, the algorithm will get + ! stuck in repetitive invocations of GEOSTEP. To this end, make sure the following. + ! 1. The threshold for CLOSE_ITPSET is at least DELBAR, the trust region radius for GEOSTEP. + ! Normally, DELBAR <= DELTA <= the threshold (In Powell's UOBYQA, DELBAR = RHO < the threshold). + ! 2. If an iteration sets IMPROVE_GEO = TRUE, it must also reduce DELTA or set DELTA to RHO. + + ! ACCURATE_MOD: Are the recent models sufficiently accurate? Used only if SHORTD is TRUE. + accurate_mod = all(abs(moderr_rec) <= 0.125_RP * crvmin * rho**2) .and. all(dnorm_rec <= rho) + ! ADEQUATE_GEO: Is the geometry of the interpolation set "adequate"? + adequate_geo = (shortd .and. accurate_mod) .or. close_itpset + ! SMALL_TRRAD: Is the trust-region radius small? This indicator seems not impactive in practice. + small_trrad = (max(delta, dnorm) <= rho) ! Behaves the same as Powell's version. + !small_trrad = (dnorm <= rho) ! Powell's code. + + ! Comments on ACCURATE_MOD: + ! 1. ACCURATE_MOD is needed only when SHORTD is TRUE. + ! 2. In Powell's UOBYQA code, ACCURATE_MOD is defined according to (28), (37), and (38) in the + ! UOBYQA paper (see also (32) of Powell 2001: "On the Lagrange functions of quadratic models + ! that are defined by interpolation"). As elaborated in Sec. 3 of the paper (also Sec. 4 of + ! Powell 2001), the idea is to test whether the current model is sufficiently accurate by + ! checking whether the interpolation error bound in (28) is (sufficiently) small. If the bound + ! is small, then set ACCURATE_MOD to TRUE. Otherwise, it identifies a "bad" interpolation point + ! that makes a significant contribution to the bound, with a preference to the interpolation + ! points that are far away from the current trust-region center. Such a point will be replaced + ! with a new point obtained by the geometry step. If all the interpolation points are close + ! enough to the trust-region center, then they are all considered to be good. + ! 3. Our implementation defines ACCURATE_MOD by a method from NEWUOA and BOBYQA, which is also + ! reflected in LINCOA. It sets ACCURATE_MOD to TRUE if recent model errors and step lengths are + ! all small. In addition, it identifies a "bad" interpolation point by simply taking the + ! farthest point from the current trust region center, unless they are all close enough to the + ! center. This implementation is much simpler and less costly in terms of flops yet it performs + ! almost the same as Powell's original implementation. + + ! Powell's original definition of IMPROVE_GEO and REDUCE_RHO: + ! !bad_trstep = (shortd .or. knew_tr == 0 .or. (ratio <= 0 .and. dnorm <= 2.0_RP*rho .and. ddmove <= 4.0_RP * rho**2)) + ! !improve_geo = bad_trstep .and. .not. (shortd .and. accurate_mod) .and. .not. close_itpset + ! !reduce_rho = bad_trstep .and. dnorm <= rho .and. .not. improve_geo + + ! IMPROVE_GEO and REDUCE_RHO are defined as follows. + ! N.B.: If SHORTD is TRUE at the very first iteration, then REDUCE_RHO will be set to TRUE. + ! Powell's code does not have TRFAIL in BAD_TRSTEP; it terminates if TRFAIL is TRUE. + + ! BAD_TRSTEP (for IMPROVE_GEO): Is the last trust-region step bad? For UOBYQA, it is CRUCIAL to + ! include DMOVE <= 4.0_RP*RHO**2 in the definition of BAD_TRSTEP for IMPROVE_GEO. + bad_trstep = (shortd .or. trfail .or. (ratio <= eta1 .and. ddmove <= 4.0_RP * delta**2) .or. knew_tr == 0) + !bad_trstep = (shortd .or. trfail .or. ratio <= eta1 .or. knew_tr == 0) ! Works poorly! + improve_geo = bad_trstep .and. .not. adequate_geo + ! BAD_TRSTEP (for REDUCE_RHO): Is the last trust-region step bad? + bad_trstep = (shortd .or. trfail .or. ratio <= 0 .or. knew_tr == 0) ! Performs better than the one below from Powell. + !bad_trstep = (shortd .or. trfail .or. (ratio <= 0 .and. ddmove <= 4.0_RP * delta**2) .or. knew_tr == 0) + reduce_rho = bad_trstep .and. adequate_geo .and. small_trrad + + ! Equivalently, REDUCE_RHO can be set as follows. It shows that REDUCE_RHO is TRUE in two cases. + ! !bad_trstep = (shortd .or. trfail .or. (ratio <= 0 .and. ddmove <= 4.0_RP * delta**2) .or. knew_tr == 0) + ! !reduce_rho = (shortd .and. accurate_mod) .or. (bad_trstep .and. close_itpset .and. small_trrad) + + ! With REDUCE_RHO properly defined, we can also set IMPROVE_GEO as follows. + ! !bad_trstep = (shortd .or. trfail .or. (ratio <= eta1 .and. ddmove <= 4.0_RP * delta**2) .or. knew_tr == 0) + ! !improve_geo = bad_trstep .and. (.not. reduce_rho) .and. (.not. close_itpset) + + ! With IMPROVE_GEO properly defined, we can also set REDUCE_RHO as follows. + ! !bad_trstep = (shortd .or. trfail .or. (ratio <= 0 .and. ddmove <= 4.0_RP * delta**2) .or. knew_tr == 0) + ! !reduce_rho = bad_trstep .and. (.not. improve_geo) .and. small_trrad + + ! UOBYQA never sets IMPROVE_GEO and REDUCE_RHO to TRUE simultaneously. + !call assert(.not. (improve_geo .and. reduce_rho), 'IMPROVE_GEO and REDUCE_RHO are not both TRUE', srname) + ! + ! If SHORTD or TRFAIL is TRUE, then either IMPROVE_GEO or REDUCE_RHO is TRUE unless CLOSE_ITPSET + ! is TRUE but SMALL_TRRAD is FALSE. + !call assert((.not. (shortd .or. trfail)) .or. (improve_geo .or. reduce_rho .or. & + ! & (close_itpset .and. .not. small_trrad)), 'If SHORTD or TRFAIL is TRUE, then either & + ! & IMPROVE_GEO or REDUCE_RHO is TRUE unless CLOSE_ITPSET is TRUE but SMALL_TRRAD is FALSE', srname) + !----------------------------------------------------------------------------------------------! + + + ! Since IMPROVE_GEO and REDUCE_RHO are never TRUE simultaneously, the following two blocks are + ! exchangeable: IF (IMPROVE_GEO) ... END IF and IF (REDUCE_RHO) ... END IF. + + ! Improve the geometry of the interpolation set by removing a point and adding a new one. + if (improve_geo) then + ! XPT(:, KNEW_GEO) will become XOPT + D below. KNEW_GEO /= KOPT unless there is a bug. + distsq = sum((xpt - spread(xpt(:, kopt), dim=2, ncopies=npt))**2, dim=1) + !!MATLAB: distsq = sum((xpt - xpt(:, kopt)).^2) % Implicit expansion + knew_geo = int(maxloc(distsq, dim=1), kind(knew_geo)) + + ! DELBAR is the trust-region radius for the geometry improvement subproblem. + ! Powell's UOBYQA code sets DELBAR = RHO, but NEWUOA/BOBYQA/LINCOA all take DELTA and/or + ! DISTSQ into consideration. + delbar = rho ! Powell's code + !delbar = max(min(TENTH * sqrt(maxval(distsq)), HALF * delta), rho) ! Powell's NEWUOA code + !delbar = max(TENTH * delta, rho) ! Powell's LINCOA code + !delbar = max(min(TENTH * sqrt(maxval(distsq)), delta), rho) ! Powell's BOBYQA code + + d = geostep(knew_geo, kopt, delbar, pl, xpt) + + ! Calculate the next value of the objective function. + ! If X is close to one of the points in the interpolation set, then we do not evaluate the + ! objective function X, assuming it to have the value at the closest point. + x = xbase + (xpt(:, kopt) + d) + distsq = [(sum((x - (xbase + xpt(:, k)))**2, dim=1), k=1, npt)] ! Implied do-loop + !!MATLAB: distsq = sum((x - (xbase + xpt))**2, 1) % Implicit expansion + k = int(minloc(distsq, dim=1), kind(k)) + if (distsq(k) <= (1.0E-4 * rhoend)**2) then + f = fval(k) + else + ! Evaluate the objective function at X, taking care of possible Inf/NaN values. + call evaluate(calfun, x, f) + nf = nf + 1_IK + ! Save X and F into the history. + call savehist(nf, x, xhist, f, fhist) + end if + + ! Print a message about the function evaluation according to IPRINT. + call fmsg(solver, 'Geometry', iprint, nf, delbar, f, x) + + ! Update DNORM_REC and MODERR_REC. + ! DNORM_REC records the DNORM of the recent function evaluations with the current RHO. + dnorm = min(delbar, norm(d)) ! In theory, DNORM = DELBAR in this case. + dnorm_rec = [dnorm_rec(2:size(dnorm_rec)), dnorm] + ! MODERR is the error of the current model in predicting the change in F due to D. + ! MODERR_REC records the prediction errors of the recent models with the current RHO. + moderr = f - fval(kopt) - quadinc(pq, d, xpt(:, kopt)) ! QUADINC = Q(XOPT + D) - Q(XOPT) + moderr_rec = [moderr_rec(2:size(moderr_rec)), moderr] + + ! Update PL, PQ, XPT, FVAL, and KOPT so that XPT(:, KNEW_GEO) becomes XOPT + D. + call update(knew_geo, d, f, moderr, kopt, fval, pl, pq, xpt) + if (.not. (all(is_finite(pq)))) then + info = NAN_INF_MODEL + exit + end if + + ! Check whether to exit + subinfo = checkexit(maxfun, nf, f, ftarget, x) + if (subinfo /= INFO_DFT) then + info = subinfo + exit + end if + end if ! End of IF (IMPROVE_GEO). The procedure of improving geometry ends. + + ! The calculations with the current RHO are complete. Enhance the resolution of the algorithm + ! by reducing RHO; update DELTA at the same time. + if (reduce_rho) then + if (rho <= rhoend) then + info = SMALL_TR_RADIUS + exit + end if + delta = max(HALF * rho, redrho(rho, rhoend)) + rho = redrho(rho, rhoend) + ! Print a message about the reduction of RHO according to IPRINT. + call rhomsg(solver, iprint, nf, delta, fval(kopt), rho, xbase + xpt(:, kopt)) + ! DNORM_REC and MODERR_REC are corresponding to the recent function evaluations with + ! the current RHO. Update them after reducing RHO. + dnorm_rec = REALMAX + moderr_rec = REALMAX + end if ! End of IF (REDUCE_RHO). The procedure of reducing RHO ends. + + ! Shifting XBASE to the best point so far, and make the corresponding changes to the gradients + ! of the Lagrange functions and the quadratic model. Powell's implementation does this each time + ! after RHO is reduced. Our implementation aligns with NEWUOA/BOBYQA/LINCOA. + if (sum(xpt(:, kopt)**2) >= 1.0E3_RP * delta**2) then + call shiftbase(kopt, pl, pq, xbase, xpt) + end if + + ! Report the current best value, and check if user asks for early termination. + if (present(callback_fcn)) then + call callback_fcn(xbase + xpt(:, kopt), fval(kopt), nf, tr, terminate=terminate) + if (terminate) then + info = CALLBACK_TERMINATE + exit + end if + end if +end do ! End of DO TR = 1, MAXTR. The iterative procedure ends. + +! Deallocate PL. F2003 automatically deallocate local ALLOCATABLE variables at exit, yet we prefer +! to deallocate them immediately when they finish their jobs. +deallocate (pl) + +! Return from the calculation, after trying the Newton-Raphson step if it has not been tried yet. +! Ensure that D has not been updated after SHORTD == TRUE occurred, or the code below is incorrect. +x = xbase + (xpt(:, kopt) + d) +if (info == SMALL_TR_RADIUS .and. shortd .and. norm(x - (xbase + xpt(:, kopt))) > TENTH * rhoend .and. nf < maxfun) then + call evaluate(calfun, x, f) + nf = nf + 1_IK + ! Save X, F into the history. + call savehist(nf, x, xhist, f, fhist) + ! Print a message about the function evaluation according to IPRINT. + ! Zaikun 20230512: DELTA has been updated. RHO is only indicative here. TO BE IMPROVED. + call fmsg(solver, 'Trust region', iprint, nf, rho, f, x) + if (f < fval(kopt)) then + xpt(:, kopt) = xpt(:, kopt) + d + fval(kopt) = f + end if +end if + +! Choose the [X, F] to return. +x = xbase + xpt(:, kopt) +f = fval(kopt) + +! Arrange FHIST and XHIST so that they are in the chronological order. +call rangehist(nf, xhist, fhist) + +! Print a return message according to IPRINT. +call retmsg(solver, info, iprint, nf, f, x) + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(nf <= maxfun, 'NF <= MAXFUN', srname) + call assert(size(x) == n .and. .not. any(is_nan(x)), 'SIZE(X) == N, X does not contain NaN', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN/+Inf', srname) + call assert(size(xhist, 1) == n .and. size(xhist, 2) == maxxhist, 'SIZE(XHIST) == [N, MAXXHIST]', srname) + call assert(.not. any(is_nan(xhist(:, 1:min(nf, maxxhist)))), 'XHIST does not contain NaN', srname) + ! The last calculated X can be Inf (finite + finite can be Inf numerically). + call assert(size(fhist) == maxfhist, 'SIZE(FHIST) == MAXFHIST', srname) + call assert(.not. any(is_nan(fhist(1:min(nf, maxfhist))) .or. is_posinf(fhist(1:min(nf, maxfhist)))), & + & 'FHIST does not contain NaN/+Inf', srname) + call assert(.not. any(fhist(1:min(nf, maxfhist)) < f), 'F is the smallest in FHIST', srname) +end if + +end subroutine uobyqb + + +end module uobyqb_mod diff --git a/examples/fortran/prima/native/uobyqa/update.f90 b/examples/fortran/prima/native/uobyqa/update.f90 new file mode 100644 index 000000000..4b7dd8566 --- /dev/null +++ b/examples/fortran/prima/native/uobyqa/update.f90 @@ -0,0 +1,121 @@ +module update_uobyqa_mod +!--------------------------------------------------------------------------------------------------! +! This module provides subroutines concerning the updates when XPT(:, KNEW) becomes XNEW = XOPT + D. +! +! Coded by Zaikun ZHANG (www.zhangzk.net) based on Powell's code and the UOBYQA paper. +! +! Dedicated to the late Professor M. J. D. Powell FRS (1936--2015). +! +! Started: July 2020 +! +! Last Modified: Thu 14 Aug 2025 07:37:19 AM CST +!--------------------------------------------------------------------------------------------------! + +implicit none +private +public :: update + + +contains + + +subroutine update(knew, d, f, moderr, kopt, fval, pl, pq, xpt) +!--------------------------------------------------------------------------------------------------! +! This subroutine updates PL, PQ, XPT, KOPT, and FVAL when XPT(:, KNEW) becomes XNEW. +! See Section 4 of the UOBYQA paper. +!--------------------------------------------------------------------------------------------------! + +! Common modules +use, non_intrinsic :: consts_mod, only : RP, IK, DEBUGGING +use, non_intrinsic :: debug_mod, only : assert +use, non_intrinsic :: infnan_mod, only : is_finite, is_nan, is_posinf +use, non_intrinsic :: linalg_mod, only : outprod +use, non_intrinsic :: powalg_mod, only : calvlag + +! Inputs +integer(IK), intent(in) :: knew +real(RP), intent(in) :: d(:) ! D(N) +real(RP), intent(in) :: f +real(RP), intent(in) :: moderr + +! In-outputs +integer(IK), intent(inout) :: kopt +real(RP), intent(inout) :: fval(:) ! FVAL(NPT) +real(RP), intent(inout) :: pl(:, :) ! PL(NPT-1, NPT) +real(RP), intent(inout) :: pq(:) ! PQ(NPT-1) +real(RP), intent(inout) :: xpt(:, :) ! XPT(N, NPT) + +! Local variables +character(len=*), parameter :: srname = 'UPDATE' +integer(IK) :: n +integer(IK) :: npt +real(RP) :: plnew(size(pl, 1)) +real(RP) :: vlag(size(xpt, 2)) + +! Sizes +n = int(size(xpt, 1), kind(n)) +npt = int(size(xpt, 2), kind(npt)) + +! Preconditions +if (DEBUGGING) then + call assert(npt == (n + 1) * (n + 2) / 2, 'NPT = (N+1)(N+2)/2', srname) + call assert(knew >= 0 .and. knew <= npt, '0 <= KNEW <= NPT', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(knew >= 1 .or. f >= fval(kopt), 'KNEW >= 1 unless X is not improved', srname) + call assert(knew /= kopt .or. f < fval(kopt), 'KNEW /= KOPT unless X is improved', srname) + call assert(size(d) == n .and. all(is_finite(d)), 'SIZE(D) == N, D is finite', srname) + call assert(.not. (is_nan(f) .or. is_posinf(f)), 'F is not NaN or +Inf', srname) + call assert(.not. any(fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) + call assert(all(is_finite(xpt)), 'XPT is finite', srname) + call assert(size(pl, 1) == npt - 1 .and. size(pl, 2) == npt, 'SIZE(PL) == [NPT-1, NPT]', srname) + call assert(size(pq) == npt - 1, 'SIZE(PQ) == NPT-1', srname) +end if + +!====================! +! Calculation starts ! +!====================! + +! Do essentially nothing when KNEW is 0. This can only happen after a trust-region step. +if (knew <= 0) then ! KNEW < 0 is impossible if the input is correct. + return +end if + +! Update the Lagrange functions. +vlag = calvlag(pl, d, xpt(:, kopt), kopt) +pl(:, knew) = pl(:, knew) / vlag(knew) +plnew = pl(:, knew) +pl = pl - outprod(plnew, vlag) +! N.B.: The use of OUTPROD is expensive memory-wise, but it is not our concern in this implementation. +pl(:, knew) = plnew + +! Update the quadratic model. +pq = pq + moderr * plnew + +! Replace the interpolation point that has index KNEW by the point XNEW. +xpt(:, knew) = xpt(:, kopt) + d +fval(knew) = f + +! KOPT is NOT identical to MINLOC(FVAL). Indeed, if FVAL(KNEW) = FVAL(KOPT) and KNEW < KOPT, then +! MINLOC(FVAL) = KNEW /= KOPT. Do not change KOPT in this case. +if (f < fval(kopt)) then + kopt = knew +end if + +!====================! +! Calculation ends ! +!====================! + +! Postconditions +if (DEBUGGING) then + call assert(size(xpt, 1) == n .and. size(xpt, 2) == npt .and. all(is_finite(xpt)), & + & 'SIZE(XPT) == [N, NPT], XPT is finite', srname) + call assert(kopt >= 1 .and. kopt <= npt, '1 <= KOPT <= NPT', srname) + call assert(.not. any(fval < fval(kopt)), 'FVAL(KOPT) = MINVAL(FVAL)', srname) + call assert(size(pl, 1) == npt - 1 .and. size(pl, 2) == npt, 'SIZE(PL) == [NPT-1, NPT]', srname) + call assert(size(pq) == npt - 1, 'SIZE(PQ) == NPT-1', srname) +end if + +end subroutine update + + +end module update_uobyqa_mod diff --git a/examples/fortran/prima/sources.txt b/examples/fortran/prima/sources.txt new file mode 100644 index 000000000..fa284f02f --- /dev/null +++ b/examples/fortran/prima/sources.txt @@ -0,0 +1,55 @@ +common/linalg.f90 +common/pintrf.f90 +common/string.f90 +common/evaluate.f90 +common/preproc.f90 +common/univar.f90 +common/powalg.f90 +common/history.f90 +common/xinbd.f90 +common/message.f90 +common/fprint.f90 +common/ratio.f90 +common/debug.F90 +common/consts.F90 +common/checkexit.f90 +common/inf.F90 +common/redrho.f90 +common/memory.F90 +common/selectx.f90 +common/huge.F90 +common/infnan.F90 +common/shiftbase.f90 +common/infos.f90 +cobyla/cobyla.f90 +cobyla/cobylb.f90 +cobyla/geometry.f90 +cobyla/initialize.f90 +cobyla/trustregion.f90 +cobyla/update.f90 +bobyqa/bobyqa.f90 +bobyqa/bobyqb.f90 +bobyqa/geometry.f90 +bobyqa/initialize.f90 +bobyqa/trustregion.f90 +bobyqa/rescue.f90 +bobyqa/update.f90 +lincoa/update.f90 +lincoa/initialize.f90 +lincoa/getact.f90 +lincoa/trustregion.f90 +lincoa/geometry.f90 +lincoa/lincob.f90 +lincoa/lincoa.f90 +newuoa/initialize.f90 +newuoa/trustregion.f90 +newuoa/geometry.f90 +newuoa/update.f90 +newuoa/newuob.f90 +newuoa/newuoa.f90 +uobyqa/initialize.f90 +uobyqa/update.f90 +uobyqa/geometry.f90 +uobyqa/trustregion.f90 +uobyqa/uobyqb.f90 +uobyqa/uobyqa.f90 diff --git a/examples/fortran/prima/tests/__init__.py b/examples/fortran/prima/tests/__init__.py new file mode 100644 index 000000000..546af8e39 --- /dev/null +++ b/examples/fortran/prima/tests/__init__.py @@ -0,0 +1 @@ +"""Runtime evidence for the PRIMA example.""" diff --git a/examples/fortran/prima/tests/test_solvers.py b/examples/fortran/prima/tests/test_solvers.py new file mode 100644 index 000000000..17fd3a9c2 --- /dev/null +++ b/examples/fortran/prima/tests/test_solvers.py @@ -0,0 +1,111 @@ +"""The selected PRIMA solver surface runs through one statically linked extension.""" + +from __future__ import annotations + +import numpy as np +import pytest + + +pytestmark = [pytest.mark.fortran_end_to_end, pytest.mark.real_library] + + +def test_public_api_is_exactly_the_five_selected_solvers(prima): + expected = { + "bobyqa_mod": "bobyqa", + "cobyla_mod": "cobyla", + "lincoa_mod": "lincoa", + "newuoa_mod": "newuoa", + "uobyqa_mod": "uobyqa", + } + assert {name for name in dir(prima) if not name.startswith("_")} == set(expected) + for module_name, procedure_name in expected.items(): + module = getattr(prima, module_name) + assert {name for name in dir(module) if not name.startswith("_")} == {procedure_name} + + +def _objective(x, f): + f[...] = (x[0] - 1.0) ** 2 + (x[1] + 2.0) ** 2 + + +@pytest.mark.parametrize( + ("module_name", "procedure_name"), + [ + ("bobyqa_mod", "bobyqa"), + ("newuoa_mod", "newuoa"), + ("uobyqa_mod", "uobyqa"), + ], +) +def test_unconstrained_solvers_minimize_a_quadratic(prima, module_name, procedure_name): + solver = getattr(getattr(prima, module_name), procedure_name) + x = np.asfortranarray(np.array([3.0, 0.0], dtype=np.float64)) + + solver(_objective, x, maxfun=np.int32(100)) + + np.testing.assert_allclose(x, np.array([1.0, -2.0]), atol=2.0e-3, rtol=0.0) + + +def test_lincoa_minimizes_a_quadratic(prima): + x = np.asfortranarray(np.array([3.0, 0.0], dtype=np.float64)) + + prima.lincoa_mod.lincoa(_objective, x, maxfun=np.int32(100)) + + np.testing.assert_allclose(x, np.array([1.0, -2.0]), atol=2.0e-3, rtol=0.0) + + +def test_cobyla_runs_with_every_optional_callback_dummy_present(prima): + x = np.asfortranarray(np.array([3.0, 0.0], dtype=np.float64)) + observed = [] + + def objective_and_constraints(values, f, constraints): + _objective(values, f) + + def progress(values, f, nf, tr, cstrv, nlconstr, terminate): + observed.append((f, nf, tr, cstrv, nlconstr.shape, terminate.shape)) + + prima.cobyla_mod.cobyla( + objective_and_constraints, + np.int32(0), + x, + maxfun=np.int32(100), + callback_fcn=progress, + ) + + np.testing.assert_allclose(x, np.array([1.0, -2.0]), atol=2.0e-3, rtol=0.0) + assert observed + assert observed[-1][4:] == ((0,), ()) + + +def test_cobyla_agrees_with_scipy_on_a_quadratic(prima): + """Cross-check the shared solver without making SciPy a build requirement.""" + optimize = pytest.importorskip("scipy.optimize") + start = np.array([3.0, 0.0], dtype=np.float64) + x = start.copy() + + def objective_and_constraints(values, result, constraints): + _objective(values, result) + + prima.cobyla_mod.cobyla(objective_and_constraints, np.int32(0), x, maxfun=np.int32(100)) + scipy_result = optimize.minimize( + lambda values: (values[0] - 1.0) ** 2 + (values[1] + 2.0) ** 2, + start, + method="COBYLA", + options={"maxiter": 100}, + ) + + expected = np.array([1.0, -2.0]) + np.testing.assert_allclose(x, expected, atol=2.0e-3, rtol=0.0) + np.testing.assert_allclose(scipy_result.x, expected, atol=2.0e-3, rtol=0.0) + np.testing.assert_allclose(x, scipy_result.x, atol=2.0e-3, rtol=0.0) + + +def test_uobyqa_callback_receives_omitted_optional_dummies_as_none(prima): + x = np.asfortranarray(np.array([3.0, 0.0], dtype=np.float64)) + observed = [] + + def progress(values, f, nf, tr, cstrv, nlconstr, terminate): + observed.append((cstrv, nlconstr, terminate.shape)) + + prima.uobyqa_mod.uobyqa(_objective, x, maxfun=np.int32(100), callback_fcn=progress) + + assert observed + assert observed[-1] == (None, None, ()) diff --git a/mkdocs.yml b/mkdocs.yml index fd5caf6ec..73e5ccdae 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -84,6 +84,7 @@ nav: - FFTPACK Wrapper: user/examples/fortran/fftpack-wrapper.md - MINPACK Wrapper: user/examples/fortran/minpack-wrapper.md - BSPLINE-FORTRAN Wrapper: user/examples/fortran/bspline-wrapper.md + - PRIMA Wrapper: user/examples/fortran/prima-wrapper.md - C: - libm Wrapper: user/examples/c/libm-wrapper.md - TA-Lib Wrapper: user/examples/c/ta-lib-wrapper.md diff --git a/prik/cli.py b/prik/cli.py index 90067f463..de50cfcd3 100644 --- a/prik/cli.py +++ b/prik/cli.py @@ -468,6 +468,12 @@ class _ParsedSemanticSources: parsed: object +@dataclass(frozen=True) +class _ConvertedSemanticSources: + files: tuple[tuple[Path, list[object]], ...] + available_modules: tuple[object, ...] + + @dataclass(frozen=True) class _SourceSemanticPipeline: parser: Callable[[_SemanticPipelineContext], _ParsedSemanticSources] @@ -495,7 +501,7 @@ def _converted_semantic_files( refresh_fortran_type_probe: bool = False, assume_intent_in_scalars: bool = False, export_symbols: tuple[str, ...] | None = None, -) -> list[tuple[Path, list[object]]]: +) -> _ConvertedSemanticSources: context = _SemanticPipelineContext( paths=paths, source_paths=_source_paths_for_semantic_pipeline( @@ -513,7 +519,24 @@ def _converted_semantic_files( ) pipeline = _SOURCE_SEMANTIC_PIPELINES[language] parsed = pipeline.parser(context) - return pipeline.converter_to_ir(parsed, context) + converted_files = pipeline.converter_to_ir(parsed, context) + available_modules = tuple(module for _path, modules in converted_files for module in modules) + if language != "fortran" or export_symbols is None: + return _ConvertedSemanticSources(tuple(converted_files), available_modules) + + from prik.semantics.fortran_exports import select_fortran_export_functions + + selection = select_fortran_export_functions(available_modules, export_symbols) + selected_by_source = { + id(source): selected + for source, selected in zip(selection.primary_sources, selection.primary_modules, strict=True) + } + selected_files = [] + for path, modules in converted_files: + selected_modules = [selected_by_source[id(module)] for module in modules if id(module) in selected_by_source] + if selected_modules: + selected_files.append((path, selected_modules)) + return _ConvertedSemanticSources(tuple(selected_files), selection.available_modules) def _semantic_report( @@ -530,7 +553,7 @@ def _semantic_report( export_symbols: tuple[str, ...] | None = None, ) -> dict[str, dict]: preprocessing = preprocessing or PreprocessingConfig() - converted_files = _converted_semantic_files( + converted = _converted_semantic_files( paths, preprocessing, language=language, @@ -542,7 +565,10 @@ def _semantic_report( assume_intent_in_scalars=assume_intent_in_scalars, export_symbols=export_symbols, ) - return _semantic_payload_for_converted_files(converted_files) + return _semantic_payload_for_converted_files( + converted.files, + available_modules=converted.available_modules, + ) def _parse_fortran_source_files( @@ -617,18 +643,19 @@ def _convert_fortran_semantic_sources( cache_dir=context.fortran_type_probe_cache_dir, refresh=context.refresh_fortran_type_probe, ) + project = FortranParser()._assemble_project([fobj for _path, fobj in parsed_files]) + compile_time_values = _fortran_compile_time_values(project, context.preprocessing, **probe_options) + type_facts = _fortran_type_facts( + project, + context.preprocessing, + compile_time_values=compile_time_values, + **probe_options, + ) converted_files = [] # A module that imports an abstract interface from another supplied file # must resolve it here, exactly as a multi-file wrapper build does. modules_by_file = {id(fobj): list(fobj.modules) for _p, fobj in parsed_files} for p, fobj in parsed_files: - compile_time_values = _fortran_compile_time_values(fobj, context.preprocessing, **probe_options) - type_facts = _fortran_type_facts( - fobj, - context.preprocessing, - compile_time_values=compile_time_values, - **probe_options, - ) modules = fortran_file_to_semantic_modules( fobj, standalone_module_name=p.stem, @@ -656,11 +683,19 @@ def _convert_fortran_semantic_sources( } -def _semantic_payload_for_converted_files(converted_files) -> dict[str, dict]: +def _semantic_payload_for_converted_files( + converted_files, + *, + available_modules=None, +) -> dict[str, dict]: from prik.pipeline.pyi import emit_module_stubs out: dict[str, dict] = {} - available_modules = [module for _p, modules in converted_files for module in modules] + available_modules = list( + available_modules + if available_modules is not None + else (module for _p, modules in converted_files for module in modules) + ) primary_names = {module.name for module in available_modules} for p, modules in converted_files: if _is_fortran_semantic_file(modules): @@ -713,6 +748,7 @@ def _fortran_contract_payload(path: Path, modules, available_modules) -> dict[st native_modules, available_modules=available_modules, normalize_public_names=True, + emit_imported_dependencies=True, ) if native_modules else {} @@ -1039,7 +1075,7 @@ def _validate_pyi_wrapper_options(args: argparse.Namespace, parser: argparse.Arg ) if getattr(args, "export_symbols", None): parser.error( - "--export-symbols selects the public surface while reading C source; a semantic .pyi " + "--export-symbols selects the public surface while reading native source; a semantic .pyi " "contract already states its public surface in __all__" ) if not getattr(args, "external_native_implementation", False) and not ( @@ -1160,15 +1196,13 @@ def _validate_wrapper_build_options(args: argparse.Namespace, parser: argparse.A def _validate_c_main_options(args: argparse.Namespace, parser: argparse.ArgumentParser) -> None: if args.language != "c": - if getattr(args, "export_symbols", None): - parser.error("--export-symbols is supported only with --language c") return if args.command == "parse" and args.show_vars: parser.error("--show-vars is Fortran-only and is not supported for --language c") -def _read_c_export_symbols(path: str | Path) -> tuple[str, ...]: - """Read one fail-closed C function allowlist from a UTF-8 text file.""" +def _read_export_symbols(path: str | Path, *, language: str) -> tuple[str, ...]: + """Read one fail-closed source-function allowlist from a UTF-8 file.""" source = Path(path) try: lines = source.read_text(encoding="utf-8").splitlines() @@ -1181,34 +1215,50 @@ def _read_c_export_symbols(path: str | Path) -> tuple[str, ...]: symbol = raw_line.split("#", 1)[0].strip() if not symbol: continue - valid = ( - symbol.isascii() - and (symbol[0].isalpha() or symbol[0] == "_") - and all(character.isalnum() or character == "_" for character in symbol) - ) + if language == "c": + valid = ( + symbol.isascii() + and (symbol[0].isalpha() or symbol[0] == "_") + and all(character.isalnum() or character == "_" for character in symbol) + ) + label = "C identifier" + duplicate_label = "C function name" + else: + from prik.semantics.fortran_exports import parse_fortran_export_identity + + try: + parse_fortran_export_identity(symbol) + except ValueError: + valid = False + else: + valid = True + label = "Fortran module procedure identity" + duplicate_label = "Fortran module procedure identity" if not valid: - raise ValueError(f"Invalid C identifier in --export-symbols file {source}:{line_number}: {symbol!r}") - previous = locations.get(symbol) + raise ValueError(f"Invalid {label} in --export-symbols file {source}:{line_number}: {symbol!r}") + identity = symbol if language == "c" else symbol.casefold() + previous = locations.get(identity) if previous is not None: raise ValueError( - f"Repeated C function name in --export-symbols file {source}:{line_number}: " + f"Repeated {duplicate_label} in --export-symbols file {source}:{line_number}: " f"{symbol!r} first appeared on line {previous}" ) - locations[symbol] = line_number + locations[identity] = line_number symbols.append(symbol) if not symbols: - raise ValueError(f"--export-symbols file contains no C function names: {source}") + label = "C function names" if language == "c" else "Fortran module procedure identities" + raise ValueError(f"--export-symbols file contains no {label}: {source}") return tuple(symbols) -def _complete_c_export_symbol_options(args: argparse.Namespace, parser: argparse.ArgumentParser) -> None: +def _complete_export_symbol_options(args: argparse.Namespace, parser: argparse.ArgumentParser) -> None: """Resolve the CLI file once for every downstream semantic/build path.""" path = getattr(args, "export_symbols", None) args._resolved_export_symbols = None if path is None: return try: - args._resolved_export_symbols = _read_c_export_symbols(path) + args._resolved_export_symbols = _read_export_symbols(path, language=args.language) except ValueError as exc: parser.error(str(exc)) @@ -1271,7 +1321,7 @@ def _validate_main_options(args: argparse.Namespace, parser: argparse.ArgumentPa _validate_c_main_options(args, parser) _validate_output_options(args, parser) - _complete_c_export_symbol_options(args, parser) + _complete_export_symbol_options(args, parser) return args.print_limit @@ -1678,6 +1728,7 @@ def record_total_build_time(elapsed: float) -> None: collision_adapter_all=getattr(args, "collision_adapter_all", False), positional_only=getattr(args, "positional_only", False), assume_intent_in_scalars=getattr(args, "assume_intent_in_scalars", False), + export_symbols=getattr(args, "_resolved_export_symbols", None), compile_input_sources=not getattr(args, "no_compile_input_sources", False), standard_logicals=getattr(args, "standard_logicals", True), native_fortran_sources=getattr(args, "native_fortran_sources", None), @@ -2332,8 +2383,9 @@ def _add_semantic_interpretation_options( "--export-symbols", metavar="FILE", help=( - "Select exact reachable C functions from a UTF-8 name file as the source-side " - "public surface; generate --pyi records the corresponding Python names in __all__" + "Select exact reachable C functions or module-qualified Fortran procedures from a UTF-8 " + "name file as the source-side public surface; generate --pyi records the corresponding " + "Python names in __all__" ), ) diff --git a/prik/pipeline/build.py b/prik/pipeline/build.py index 699ea0d30..bc400693a 100644 --- a/prik/pipeline/build.py +++ b/prik/pipeline/build.py @@ -2330,12 +2330,14 @@ def _apply_source_python_exports(modules: list[SemanticModule]) -> None: complete_reexport_publication_policy(module, contract_named=False) module.metadata[PYTHON_EXPORTS_PREPARED_METADATA] = True namespace = (module.name.casefold(),) if module.origin.source_kind == "module" else () + stated = None if module.exported_names is None else {str(name) for name in module.exported_names} for declaration in _module_declarations(module): _set_declaration_exports( declaration, ( [] if getattr(declaration, "visibility", "public") == "private" + or (stated is not None and str(declaration.name) not in stated) else [{"namespace": namespace, "name": None}] ), ) @@ -3517,6 +3519,7 @@ def _fortran_wrapper_module( fortran_type_probe_cache_dir: str | Path | None, refresh_fortran_type_probe: bool, assume_intent_in_scalars: bool = False, + export_symbols: Iterable[str] | None = None, ) -> tuple[object, SemanticModule, tuple[SemanticModule, ...], tuple[Path, ...]]: """Parse Fortran sources, resolve type facts, and form one wrapper module.""" # Preprocess and parse the complete source project. @@ -3554,6 +3557,13 @@ def _fortran_wrapper_module( type_facts=type_facts, assume_intent_in_scalars=assume_intent_in_scalars, ) + if export_symbols is not None: + from prik.semantics.fortran_exports import select_fortran_export_functions + + selection = select_fortran_export_functions(modules, export_symbols) + for context_module in selection.context_modules: + context_module.exported_names = [] + modules = list(selection.available_modules) _apply_source_python_exports(modules) module_name = _validated_wrapper_module_name(output_name, source_paths[0].stem) return ( @@ -3656,6 +3666,7 @@ def build_fortran_extension( collision_adapter_all: bool = False, positional_only: bool = False, assume_intent_in_scalars: bool = False, + export_symbols: Iterable[str] | None = None, fortran_type_report=None, fortran_type_probe_runner: list[str] | None = None, fortran_type_probe_cache_dir: str | Path | None = None, @@ -3723,6 +3734,11 @@ def build_fortran_extension( ``character`` dummies follow the same rule. A declared ``intent`` is always honored, and arrays, derived-type objects, and allocatable or pointer scalars are unaffected. + export_symbols + Exact case-insensitive ``module::procedure`` identities to publish + from the source universe. Signature dependencies remain available but + are not added to the callable surface. A generated semantic contract + records the corresponding Python surface in ``__all__``. fortran_type_report, fortran_type_probe_runner, fortran_type_probe_cache_dir, refresh_fortran_type_probe Optional controls for compiler-probed Fortran type facts used while @@ -3819,6 +3835,7 @@ def build_fortran_extension( fortran_type_probe_cache_dir=fortran_type_probe_cache_dir, refresh_fortran_type_probe=refresh_fortran_type_probe, assume_intent_in_scalars=assume_intent_in_scalars, + export_symbols=export_symbols, ) # 3. Complete wrapper policy and generate the canonical wrapper. diff --git a/prik/pipeline/pyi.py b/prik/pipeline/pyi.py index 030c89320..b7d0531ff 100644 --- a/prik/pipeline/pyi.py +++ b/prik/pipeline/pyi.py @@ -19,7 +19,13 @@ from prik.policy.contract_imports import complete_contract_imports from prik.policy.exports import complete_python_export_policy from prik.printers.pyi import emit_module -from prik.semantics.models import EXTERNAL_TYPE_REF_METADATA, SemanticClass, SemanticModule, _module_semantic_types +from prik.semantics.models import ( + EXTERNAL_TYPE_REF_METADATA, + SemanticClass, + SemanticImport, + SemanticModule, + _module_semantic_types, +) from prik.semantics.pyi_metadata import PYI_LOADED_METADATA from prik.semantics.pyi2ir import convert_pyi_to_ir, reconcile_external_type_refs @@ -107,6 +113,7 @@ def emit_module_stubs( *, available_modules: Iterable[SemanticModule] | None = None, normalize_public_names: bool = False, + emit_imported_dependencies: bool = False, ) -> dict[str, str]: """Complete and render semantic modules plus opaque dependencies. @@ -115,7 +122,8 @@ def emit_module_stubs( starter-contract extraction: they preserve parser facts without invoking direct-wrapper policy, which is only required by a build request. The returned mapping is keyed by module name and is normally written into a - generated contract package by a pipeline stage. + generated contract package by a pipeline stage. When requested, modules + reached by completed relative contract imports are emitted as well. """ source_modules = _module_list(modules) available = _module_list(available_modules) if available_modules is not None else source_modules @@ -152,12 +160,42 @@ def emit_module_stubs( emitted_modules.values(), dependencies=(module for name, module in naming_modules.items() if name not in emitted_modules), ) + if emit_imported_dependencies: + _add_imported_contract_dependencies(emitted_modules, naming_modules) return { module_name: emit_module(module, normalize_public_names=normalize_public_names).strip() for module_name, module in emitted_modules.items() } +def _add_imported_contract_dependencies( + emitted_modules: dict[str, SemanticModule], + naming_modules: dict[str, SemanticModule], +) -> None: + """Emit the available modules completed contract imports actually bind.""" + available = {name.casefold(): module for name, module in naming_modules.items()} + pending = list(emitted_modules.values()) + while pending: + module = pending.pop(0) + dependency_names = { + statement.module.lstrip(".").casefold() + for statement in module.imports + if isinstance(statement, SemanticImport) and statement.module.startswith(".") + } + for dependency_name in sorted(dependency_names): + dependency = available.get(dependency_name) + if dependency is None or dependency.name in emitted_modules: + continue + completed = deepcopy(dependency) + complete_semantic_policies([completed]) + complete_contract_imports( + [completed], + dependencies=(item for name, item in naming_modules.items() if name != completed.name), + ) + emitted_modules[completed.name] = completed + pending.append(completed) + + @dataclass class _PyiSemanticModuleCache: modules: dict[tuple[Path, str, str, str], SemanticModule] = field(default_factory=dict) diff --git a/prik/semantics/fortran_exports.py b/prik/semantics/fortran_exports.py new file mode 100644 index 000000000..f2d5f73a1 --- /dev/null +++ b/prik/semantics/fortran_exports.py @@ -0,0 +1,174 @@ +"""Exact source-side export selection for Fortran semantic modules.""" + +from __future__ import annotations + +from collections.abc import Iterable +from copy import deepcopy +from dataclasses import dataclass +import re + +from prik.semantics.models import ProcedureOverloadSet, SemanticFunction, SemanticModule + + +_FORTRAN_IDENTIFIER = r"[A-Za-z][A-Za-z0-9_]*" +_FORTRAN_EXPORT_RE = re.compile(rf"^(?P{_FORTRAN_IDENTIFIER})::(?P{_FORTRAN_IDENTIFIER})$") + + +@dataclass(frozen=True) +class FortranExportSelection: + """Selected wrapper roots and the surrounding semantic source context.""" + + primary_sources: tuple[SemanticModule, ...] + primary_modules: tuple[SemanticModule, ...] + context_modules: tuple[SemanticModule, ...] + + @property + def available_modules(self) -> tuple[SemanticModule, ...]: + return (*self.primary_modules, *self.context_modules) + + +def parse_fortran_export_identity(value: str) -> tuple[str, str]: + """Return one case-folded ``module::procedure`` identity or raise.""" + match = _FORTRAN_EXPORT_RE.fullmatch(str(value)) + if match is None: + raise ValueError(f"invalid Fortran procedure identity: {value}") + return match.group("module").casefold(), match.group("procedure").casefold() + + +def select_fortran_export_functions( + modules: Iterable[SemanticModule], + symbols: Iterable[str], +) -> FortranExportSelection: + """Select exact module procedures with their semantic source context. + + Selection is expressed in native identities before policy names anything. + Primary module copies contain only the requested callable declarations; + their classes, prototypes, variables, and reexports remain available as + signature facts but are not added to the stated public surface. Other + source modules remain available as context. Contract-import policy decides + which of them the generated contract needs to emit. + """ + source_modules = tuple( + module + for module in modules + if module.origin.source_language == "fortran" and module.origin.source_kind == "module" + ) + requested = _validated_fortran_export_symbols(symbols) + module_index = {_native_module_name(module): module for module in source_modules} + callable_index, non_callable_index = _fortran_export_candidates(source_modules) + _validate_fortran_export_resolution(requested, callable_index, non_callable_index, module_index) + + selected = set(requested) + primary_names = {module_name for module_name, _procedure_name in requested} + primary_sources = [] + primary_modules = [] + for module in source_modules: + module_name = _native_module_name(module) + if module_name not in primary_names: + continue + selected_module = deepcopy(module) + selected_module.functions = [ + function + for function in selected_module.functions + if (module_name, _native_procedure_name(function)) in selected + ] + selected_module.overload_sets = [ + overload + for overload in selected_module.overload_sets + if (module_name, _native_procedure_name(overload)) in selected + ] + selected_module.exported_names = [ + declaration.name for declaration in (*selected_module.functions, *selected_module.overload_sets) + ] + primary_sources.append(module) + primary_modules.append(selected_module) + + # Root selection owns only the requested callable surface. Contract-import + # completion already owns which available modules selected declarations + # actually name, including private callback prototypes and imported types + # that are not Fortran reexports. Keep the remaining modules available and + # let that one authority emit only the dependencies the contract binds. + context_names = tuple(name for name in module_index if name not in primary_names) + context_modules = tuple(deepcopy(module_index[name]) for name in context_names) + return FortranExportSelection(tuple(primary_sources), tuple(primary_modules), context_modules) + + +def _validated_fortran_export_symbols(symbols: Iterable[str]) -> tuple[tuple[str, str], ...]: + requested_text = tuple(str(symbol) for symbol in symbols) + if not requested_text: + raise ValueError("Fortran export-symbol selection requires at least one module procedure identity") + requested = [] + invalid = [] + repeated = [] + seen: set[tuple[str, str]] = set() + for value in requested_text: + try: + identity = parse_fortran_export_identity(value) + except ValueError: + invalid.append(value) + continue + if identity in seen and value not in repeated: + repeated.append(value) + seen.add(identity) + requested.append(identity) + problems = [] + if invalid: + problems.append("invalid procedure identities: " + ", ".join(invalid)) + if repeated: + problems.append("repeated identities: " + ", ".join(repeated)) + if problems: + raise ValueError("Fortran export-symbol selection failed: " + "; ".join(problems)) + return tuple(requested) + + +def _fortran_export_candidates(modules: tuple[SemanticModule, ...]): + callables: dict[tuple[str, str], list[object]] = {} + non_callables: set[tuple[str, str]] = set() + for module in modules: + module_name = _native_module_name(module) + for declaration in (*module.functions, *module.overload_sets): + callables.setdefault((module_name, _native_procedure_name(declaration)), []).append(declaration) + for declaration in (*module.variables, *module.classes, *module.prototypes): + non_callables.add((module_name, _native_procedure_name(declaration))) + return callables, non_callables + + +def _validate_fortran_export_resolution(requested, callables, non_callables, module_index) -> None: + problems = [] + unknown_modules = [module for module, _name in requested if module not in module_index] + non_functions = [identity for identity in requested if identity in non_callables and identity not in callables] + unknown = [ + identity + for identity in requested + if identity[0] in module_index and identity not in callables and identity not in non_callables + ] + ambiguous = [identity for identity in requested if len(callables.get(identity, ())) > 1] + inaccessible = [ + identity + for identity in requested + if any(getattr(declaration, "visibility", "public") == "private" for declaration in callables.get(identity, ())) + ] + for label, identities in ( + ("unknown modules", tuple(dict.fromkeys(unknown_modules))), + ("unknown procedures", unknown), + ("non-function declarations", non_functions), + ("ambiguous procedures", ambiguous), + ("private procedures", inaccessible), + ): + if identities: + formatted = [item if isinstance(item, str) else "::".join(item) for item in identities] + problems.append(f"{label}: {', '.join(formatted)}") + if problems: + raise ValueError("Fortran export-symbol selection failed: " + "; ".join(problems)) + + +def _native_module_name(module: SemanticModule) -> str: + return str(module.origin.native_name or module.name).casefold() + + +def _native_procedure_name(declaration: object) -> str: + if isinstance(declaration, ProcedureOverloadSet): + return str(declaration.name).casefold() + if isinstance(declaration, SemanticFunction): + return str(declaration.origin.native_name or declaration.native_name or declaration.name).casefold() + return str(getattr(getattr(declaration, "origin", None), "native_name", None) or declaration.name).casefold() diff --git a/tests/c/functions/semantics/test_export_symbol_selection.py b/tests/c/functions/semantics/test_export_symbol_selection.py index 62baf3c99..36e610997 100644 --- a/tests/c/functions/semantics/test_export_symbol_selection.py +++ b/tests/c/functions/semantics/test_export_symbol_selection.py @@ -4,7 +4,7 @@ import pytest -from prik.cli import _read_c_export_symbols +from prik.cli import _read_export_symbols from prik.parsers.c.models import CFile, CFunction, CInt, CVariable from prik.semantics.c2ir import CToIRConverter, select_c_export_functions from prik.semantics.metadata import EXPLICIT_C_EXPORT_METADATA @@ -64,8 +64,8 @@ def test_export_selection_rejects_an_ambiguous_function_name(): def test_export_symbol_file_accepts_comments_and_rejects_duplicates(tmp_path: Path): export_file = tmp_path / "exports.txt" export_file.write_text("# reviewed\nkeep # public\n\ndrop\n", encoding="utf-8") - assert _read_c_export_symbols(export_file) == ("keep", "drop") + assert _read_export_symbols(export_file, language="c") == ("keep", "drop") export_file.write_text("keep\nkeep\n", encoding="utf-8") with pytest.raises(ValueError, match="first appeared on line 1"): - _read_c_export_symbols(export_file) + _read_export_symbols(export_file, language="c") diff --git a/tests/docs/test_examples.py b/tests/docs/test_examples.py index 3faad7728..7fc3ccae9 100644 --- a/tests/docs/test_examples.py +++ b/tests/docs/test_examples.py @@ -29,6 +29,7 @@ ROOT / "examples/c/README.md", ROOT / "examples/c/libm/README.md", ROOT / "examples/fortran/minpack/README.md", + ROOT / "examples/fortran/prima/README.md", ROOT / "examples/fortran/pythonic_blas/README.md", ROOT / "examples/c/ta_lib/README.md", *sorted((ROOT / "docs").rglob("*.md")), diff --git a/tests/fortran/functions/end_to_end/fixtures/export_symbols.txt b/tests/fortran/functions/end_to_end/fixtures/export_symbols.txt new file mode 100644 index 000000000..e9be8f9a2 --- /dev/null +++ b/tests/fortran/functions/end_to_end/fixtures/export_symbols.txt @@ -0,0 +1,2 @@ +# The same procedure spelling exists in another module. +selected_solver_mod::solve diff --git a/tests/fortran/functions/end_to_end/fixtures/native/export_selection/callbacks.f90 b/tests/fortran/functions/end_to_end/fixtures/native/export_selection/callbacks.f90 new file mode 100644 index 000000000..55a3284b0 --- /dev/null +++ b/tests/fortran/functions/end_to_end/fixtures/native/export_selection/callbacks.f90 @@ -0,0 +1,14 @@ +module export_callbacks_mod + use export_kinds_mod, only : ik + implicit none + private + public :: report + + abstract interface + subroutine report(value, status) + import ik + integer(ik), intent(in) :: value + integer(ik), intent(in), optional :: status + end subroutine report + end interface +end module export_callbacks_mod diff --git a/tests/fortran/functions/end_to_end/fixtures/native/export_selection/kinds.f90 b/tests/fortran/functions/end_to_end/fixtures/native/export_selection/kinds.f90 new file mode 100644 index 000000000..35bb6d849 --- /dev/null +++ b/tests/fortran/functions/end_to_end/fixtures/native/export_selection/kinds.f90 @@ -0,0 +1,4 @@ +module export_kinds_mod + implicit none + integer, parameter :: ik = kind(0) +end module export_kinds_mod diff --git a/tests/fortran/functions/end_to_end/fixtures/native/export_selection/selected.f90 b/tests/fortran/functions/end_to_end/fixtures/native/export_selection/selected.f90 new file mode 100644 index 000000000..035cc53b5 --- /dev/null +++ b/tests/fortran/functions/end_to_end/fixtures/native/export_selection/selected.f90 @@ -0,0 +1,20 @@ +module selected_solver_mod + use export_kinds_mod, only : ik + use export_callbacks_mod, only : report + implicit none + private + public :: solve, hidden_solver +contains + subroutine solve(value, callback) + integer(ik), intent(inout) :: value + procedure(report), optional :: callback + + value = value + 1 + if (present(callback)) call callback(value) + end subroutine solve + + subroutine hidden_solver(value) + integer(ik), intent(inout) :: value + value = value + 100 + end subroutine hidden_solver +end module selected_solver_mod diff --git a/tests/fortran/functions/end_to_end/fixtures/native/export_selection/unrelated.f90 b/tests/fortran/functions/end_to_end/fixtures/native/export_selection/unrelated.f90 new file mode 100644 index 000000000..a2dac1e5e --- /dev/null +++ b/tests/fortran/functions/end_to_end/fixtures/native/export_selection/unrelated.f90 @@ -0,0 +1,11 @@ +module unrelated_solver_mod + use export_kinds_mod, only : ik + implicit none + private + public :: solve +contains + subroutine solve(value) + integer(ik), intent(inout) :: value + value = value - 1 + end subroutine solve +end module unrelated_solver_mod diff --git a/tests/fortran/functions/end_to_end/test_fortran_export_symbol_workflow.py b/tests/fortran/functions/end_to_end/test_fortran_export_symbol_workflow.py new file mode 100644 index 000000000..b9549ad79 --- /dev/null +++ b/tests/fortran/functions/end_to_end/test_fortran_export_symbol_workflow.py @@ -0,0 +1,131 @@ +"""Generated contracts and runtime builds share Fortran export selection.""" + +from __future__ import annotations + +import subprocess +import sys +from pathlib import Path +import shutil + +import numpy as np +import pytest + +from prik import build_fortran_extension, build_pyi_extension +from tests.fortran._support.wrapper_build import _import_from_build_dir + + +FIXTURES = Path(__file__).parent / "fixtures" +NATIVE = FIXTURES / "native" / "export_selection" +SOURCES = tuple(NATIVE / name for name in ("kinds.f90", "callbacks.f90", "selected.f90", "unrelated.f90")) +EXPORTS = ("selected_solver_mod::solve",) +pytestmark = pytest.mark.fortran_end_to_end + + +def _generate_contract(tmp_path: Path) -> Path: + contract = tmp_path / "contract" + subprocess.run( + [ + sys.executable, + "-m", + "prik", + "generate", + "--pyi", + *map(str, SOURCES), + "--export-symbols", + str(FIXTURES / "export_symbols.txt"), + "--out", + str(contract), + ], + check=True, + capture_output=True, + text=True, + ) + return contract + + +def test_generate_pyi_emits_only_the_selected_module_and_callback_dependency(tmp_path: Path): + contract = _generate_contract(tmp_path) + + assert {path.name for path in contract.iterdir()} == { + "__init__.pyi", + "export_callbacks_mod.pyi", + "selected_solver_mod.pyi", + } + selected = (contract / "selected_solver_mod.pyi").read_text(encoding="utf-8") + assert "def solve(" in selected + assert "hidden_solver" not in selected + assert "from .export_callbacks_mod import report" in selected + assert '__all__ = ["solve"]' in selected + assert '__all__ = ["selected_solver_mod"]' in (contract / "__init__.pyi").read_text(encoding="utf-8") + + +def test_module_identity_ignores_same_named_external_root(tmp_path: Path): + source = tmp_path / "foo.f90" + source.write_text( + """module foo +contains + subroutine chosen() + end subroutine chosen +end module foo + +subroutine external() +end subroutine external +""", + encoding="utf-8", + ) + exports = tmp_path / "exports.txt" + exports.write_text("foo::chosen\n", encoding="utf-8") + contract = tmp_path / "contract" + + subprocess.run( + [ + sys.executable, + "-m", + "prik", + "generate", + "--pyi", + str(source), + "--export-symbols", + str(exports), + "--out", + str(contract), + ], + check=True, + capture_output=True, + text=True, + ) + + assert {path.name for path in contract.iterdir()} == {"__init__.pyi", "foo.pyi"} + assert "def chosen(" in (contract / "foo.pyi").read_text(encoding="utf-8") + assert "external" not in (contract / "foo.pyi").read_text(encoding="utf-8") + + +@pytest.mark.skipif(shutil.which("gfortran") is None, reason="requires gfortran") +def test_source_and_generated_contract_builds_publish_and_run_the_same_callback(tmp_path: Path): + source_result = build_fortran_extension( + SOURCES, + output_dir=tmp_path / "source_build", + output_name="selected_exports", + export_symbols=EXPORTS, + jobs=2, + ) + contract = _generate_contract(tmp_path) + contract_result = build_pyi_extension( + contract / "__init__.pyi", + native_fortran_sources=SOURCES, + output_dir=tmp_path / "contract_build", + output_name="selected_contract", + jobs=2, + ) + for result in (source_result, contract_result): + root = _import_from_build_dir(result.module_name, result.output_dir) + assert {name for name in dir(root) if not name.startswith("_")} == {"selected_solver_mod"} + module = root.selected_solver_mod + assert {name for name in dir(module) if not name.startswith("_")} == {"solve"} + seen = [] + + def callback(value, status, *, observed=seen): + observed.append((value, status)) + + assert module.solve(np.int32(4), callback) == np.int32(5) + assert seen == [(np.int32(5), None)] diff --git a/tests/fortran/functions/semantics/test_fortran_export_symbol_selection.py b/tests/fortran/functions/semantics/test_fortran_export_symbol_selection.py new file mode 100644 index 000000000..109920806 --- /dev/null +++ b/tests/fortran/functions/semantics/test_fortran_export_symbol_selection.py @@ -0,0 +1,131 @@ +"""Fortran source export selection owns one qualified callable surface.""" + +from pathlib import Path + +import pytest + +from prik.cli import _read_export_symbols +from prik.semantics.fortran_exports import select_fortran_export_functions +from prik.semantics.models import ( + ProcedureOverloadSet, + SemanticFunction, + SemanticModule, + SemanticOrigin, + SemanticPrototype, + SemanticReexport, + SemanticType, + SemanticVariable, +) + + +def _module(name: str, *, functions=(), prototypes=(), variables=(), reexports=()): + return SemanticModule( + name=name, + functions=list(functions), + prototypes=list(prototypes), + variables=list(variables), + reexports=list(reexports), + origin=SemanticOrigin(source_language="fortran", native_name=name, source_kind="module"), + ) + + +def _function(module: str, name: str): + return SemanticFunction( + name=name, + native_name=name, + origin=SemanticOrigin(source_language="fortran", native_name=name, native_scope=module), + ) + + +def test_selection_keeps_one_callable_root_and_its_declaration_module(): + callback = SemanticPrototype( + name="REPORT", + origin=SemanticOrigin(source_language="fortran", native_name="report", native_scope="callbacks_mod"), + ) + callbacks = _module("callbacks_mod", prototypes=[callback]) + selected = _module( + "solver_mod", + functions=[_function("solver_mod", "solve"), _function("solver_mod", "helper")], + variables=[SemanticVariable(name="state", semantic_type=SemanticType(name="Int32"))], + reexports=[ + SemanticReexport( + local_name="REPORT", + origin_module="callbacks_mod", + source_name="REPORT", + declaration_dependency=True, + ) + ], + ) + + result = select_fortran_export_functions([callbacks, selected], ["SOLVER_MOD::SOLVE"]) + + assert [module.name for module in result.primary_modules] == ["solver_mod"] + assert [function.name for function in result.primary_modules[0].functions] == ["solve"] + assert result.primary_modules[0].exported_names == ["solve"] + assert [module.name for module in result.context_modules] == ["callbacks_mod"] + assert result.context_modules[0].exported_names is None + + +def test_fortran_export_file_accepts_comments_and_rejects_case_insensitive_duplicates(tmp_path: Path): + export_file = tmp_path / "exports.txt" + export_file.write_text("# reviewed\nsolver_mod::solve # public\n", encoding="utf-8") + assert _read_export_symbols(export_file, language="fortran") == ("solver_mod::solve",) + + export_file.write_text("solver_mod::solve\nSOLVER_MOD::SOLVE\n", encoding="utf-8") + with pytest.raises(ValueError, match="first appeared on line 1"): + _read_export_symbols(export_file, language="fortran") + + +@pytest.mark.parametrize( + ("symbols", "message"), + [ + ([], "requires at least one module procedure identity"), + (["solve"], "invalid procedure identities: solve"), + (["solver_mod::solve", "SOLVER_MOD::SOLVE"], "repeated identities"), + (["missing_mod::solve"], "unknown modules: missing_mod"), + (["solver_mod::missing"], "unknown procedures: solver_mod::missing"), + (["solver_mod::state"], "non-function declarations: solver_mod::state"), + ], +) +def test_selection_rejects_invalid_or_unresolved_identities(symbols, message): + module = _module( + "solver_mod", + functions=[_function("solver_mod", "solve")], + variables=[SemanticVariable(name="state", semantic_type=SemanticType(name="Int32"))], + ) + + with pytest.raises(ValueError, match=message): + select_fortran_export_functions([module], symbols) + + +def test_selection_rejects_private_module_procedure(): + hidden = _function("solver_mod", "hidden") + hidden.visibility = "private" + with pytest.raises(ValueError, match="private procedures: solver_mod::hidden"): + select_fortran_export_functions([_module("solver_mod", functions=[hidden])], ["solver_mod::hidden"]) + + +def test_selection_keeps_one_generic_with_its_specific_candidates(): + specific_int = _function("solver_mod", "solve_int") + specific_real = _function("solver_mod", "solve_real") + generic = ProcedureOverloadSet(name="solve", procedures=[specific_int, specific_real], native_scope="solver_mod") + module = _module( + "solver_mod", + functions=[specific_int, specific_real, _function("solver_mod", "helper")], + ) + module.overload_sets = [generic] + + selected = select_fortran_export_functions([module], ["SOLVER_MOD::SOLVE"]).primary_modules[0] + + assert selected.functions == [] + assert [overload.name for overload in selected.overload_sets] == ["solve"] + assert [candidate.name for candidate in selected.overload_sets[0].procedures] == ["solve_int", "solve_real"] + assert selected.exported_names == ["solve"] + + +def test_external_root_cannot_satisfy_a_module_qualified_identity(): + external = _module("foo", functions=[_function("foo", "external")]) + external.origin.source_kind = "external_root" + + with pytest.raises(ValueError, match="unknown modules: foo"): + select_fortran_export_functions([external], ["foo::external"])