From 57f5c604ea84a69f2c7a4f03091fdfe7d8e70884 Mon Sep 17 00:00:00 2001 From: said Date: Tue, 22 Sep 2026 20:54:18 +0100 Subject: [PATCH 1/6] codex: select Fortran source exports --- CHANGELOG.md | 6 + docs/user/faq/index.md | 14 +- docs/user/reference/cli-commands.md | 57 ++++-- docs/user/reference/python-api.md | 14 ++ prik/cli.py | 121 +++++++++---- prik/pipeline/build.py | 17 ++ prik/pipeline/pyi.py | 42 ++++- prik/semantics/fortran_exports.py | 167 ++++++++++++++++++ .../semantics/test_export_symbol_selection.py | 6 +- .../end_to_end/fixtures/export_symbols.txt | 2 + .../native/export_selection/callbacks.f90 | 14 ++ .../native/export_selection/kinds.f90 | 4 + .../native/export_selection/selected.f90 | 20 +++ .../native/export_selection/unrelated.f90 | 11 ++ .../test_fortran_export_symbol_workflow.py | 90 ++++++++++ .../test_fortran_export_symbol_selection.py | 104 +++++++++++ 16 files changed, 635 insertions(+), 54 deletions(-) create mode 100644 prik/semantics/fortran_exports.py create mode 100644 tests/fortran/functions/end_to_end/fixtures/export_symbols.txt create mode 100644 tests/fortran/functions/end_to_end/fixtures/native/export_selection/callbacks.f90 create mode 100644 tests/fortran/functions/end_to_end/fixtures/native/export_selection/kinds.f90 create mode 100644 tests/fortran/functions/end_to_end/fixtures/native/export_selection/selected.f90 create mode 100644 tests/fortran/functions/end_to_end/fixtures/native/export_selection/unrelated.f90 create mode 100644 tests/fortran/functions/end_to_end/test_fortran_export_symbol_workflow.py create mode 100644 tests/fortran/functions/semantics/test_fortran_export_symbol_selection.py diff --git a/CHANGELOG.md b/CHANGELOG.md index 9ca6a42dd..4024cfc48 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,12 @@ 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. + - 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/docs/user/faq/index.md b/docs/user/faq/index.md index 80bd4ba8f..f1a7ec086 100644 --- a/docs/user/faq/index.md +++ b/docs/user/faq/index.md @@ -107,7 +107,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 +132,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/reference/cli-commands.md b/docs/user/reference/cli-commands.md index 942dc3ae8..275872b7c 100644 --- a/docs/user/reference/cli-commands.md +++ b/docs/user/reference/cli-commands.md @@ -378,6 +378,42 @@ 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. 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 +425,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 +437,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/prik/cli.py b/prik/cli.py index 90067f463..3435c63e4 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,27 @@ 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_module = { + str(module.origin.native_name or module.name).casefold(): module for module in selection.primary_modules + } + selected_files = [] + for path, modules in converted_files: + selected_modules = [ + selected_by_module[name] + for module in modules + if (name := str(module.origin.native_name or module.name).casefold()) in selected_by_module + ] + if selected_modules: + selected_files.append((path, selected_modules)) + return _ConvertedSemanticSources(tuple(selected_files), selection.available_modules) def _semantic_report( @@ -530,7 +556,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 +568,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 +646,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 +686,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 +751,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 +1078,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 +1199,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 +1218,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 +1324,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 +1731,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 +2386,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..c6793b418 --- /dev/null +++ b/prik/semantics/fortran_exports.py @@ -0,0 +1,167 @@ +"""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_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(modules) + 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_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_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_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/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..b7f476bb7 --- /dev/null +++ b/tests/fortran/functions/end_to_end/test_fortran_export_symbol_workflow.py @@ -0,0 +1,90 @@ +"""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") + + +@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..b72d7dd86 --- /dev/null +++ b/tests/fortran/functions/semantics/test_fortran_export_symbol_selection.py @@ -0,0 +1,104 @@ +"""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 ( + 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"]) From 65b91531e166e837e826824ffa532e2159da5c0c Mon Sep 17 00:00:00 2001 From: said Date: Tue, 22 Sep 2026 20:55:08 +0100 Subject: [PATCH 2/6] codex: add PRIMA static library example --- CHANGELOG.md | 2 + examples/fortran/README.md | 1 + examples/fortran/prima/CMakeLists.txt | 19 + examples/fortran/prima/LICENCE.txt | 28 + examples/fortran/prima/README.md | 52 + examples/fortran/prima/__init__.py | 1 + examples/fortran/prima/build_all.sh | 3 + examples/fortran/prima/build_prik.sh | 36 + examples/fortran/prima/conftest.py | 11 + examples/fortran/prima/export_symbols.txt | 5 + .../fortran/prima/native/bobyqa/bobyqa.f90 | 535 +++ .../fortran/prima/native/bobyqa/bobyqb.f90 | 784 +++++ .../fortran/prima/native/bobyqa/geometry.f90 | 618 ++++ .../prima/native/bobyqa/initialize.f90 | 557 +++ .../fortran/prima/native/bobyqa/rescue.f90 | 803 +++++ .../prima/native/bobyqa/trustregion.f90 | 712 ++++ .../fortran/prima/native/bobyqa/update.f90 | 502 +++ .../fortran/prima/native/cobyla/cobyla.f90 | 867 +++++ .../fortran/prima/native/cobyla/cobylb.f90 | 939 +++++ .../fortran/prima/native/cobyla/geometry.f90 | 304 ++ .../prima/native/cobyla/initialize.f90 | 353 ++ .../prima/native/cobyla/trustregion.f90 | 670 ++++ .../fortran/prima/native/cobyla/update.f90 | 407 +++ .../fortran/prima/native/common/checkexit.f90 | 178 + .../fortran/prima/native/common/consts.F90 | 266 ++ .../fortran/prima/native/common/debug.F90 | 174 + .../fortran/prima/native/common/evaluate.f90 | 214 ++ .../fortran/prima/native/common/fprint.f90 | 152 + .../fortran/prima/native/common/history.f90 | 458 +++ examples/fortran/prima/native/common/huge.F90 | 80 + examples/fortran/prima/native/common/inf.F90 | 221 ++ .../fortran/prima/native/common/infnan.F90 | 153 + .../fortran/prima/native/common/infos.f90 | 56 + .../fortran/prima/native/common/linalg.f90 | 3105 +++++++++++++++++ .../fortran/prima/native/common/memory.F90 | 561 +++ .../fortran/prima/native/common/message.f90 | 447 +++ .../fortran/prima/native/common/pintrf.f90 | 56 + .../fortran/prima/native/common/powalg.f90 | 1940 ++++++++++ examples/fortran/prima/native/common/ppf.h | 180 + .../fortran/prima/native/common/preproc.f90 | 448 +++ .../fortran/prima/native/common/ratio.f90 | 83 + .../fortran/prima/native/common/redrho.f90 | 71 + .../fortran/prima/native/common/selectx.f90 | 530 +++ .../fortran/prima/native/common/shiftbase.f90 | 255 ++ .../fortran/prima/native/common/string.f90 | 353 ++ .../fortran/prima/native/common/univar.f90 | 306 ++ .../fortran/prima/native/common/xinbd.f90 | 79 + .../fortran/prima/native/lincoa/geometry.f90 | 476 +++ .../fortran/prima/native/lincoa/getact.f90 | 589 ++++ .../prima/native/lincoa/initialize.f90 | 421 +++ .../fortran/prima/native/lincoa/lincoa.f90 | 786 +++++ .../fortran/prima/native/lincoa/lincob.f90 | 763 ++++ .../prima/native/lincoa/trustregion.f90 | 601 ++++ .../fortran/prima/native/lincoa/update.f90 | 391 +++ .../fortran/prima/native/newuoa/geometry.f90 | 888 +++++ .../prima/native/newuoa/initialize.f90 | 519 +++ .../fortran/prima/native/newuoa/newuoa.f90 | 421 +++ .../fortran/prima/native/newuoa/newuob.f90 | 693 ++++ .../prima/native/newuoa/trustregion.f90 | 555 +++ .../fortran/prima/native/newuoa/update.f90 | 316 ++ .../fortran/prima/native/uobyqa/geometry.f90 | 455 +++ .../prima/native/uobyqa/initialize.f90 | 461 +++ .../prima/native/uobyqa/trustregion.f90 | 649 ++++ .../fortran/prima/native/uobyqa/uobyqa.f90 | 407 +++ .../fortran/prima/native/uobyqa/uobyqb.f90 | 600 ++++ .../fortran/prima/native/uobyqa/update.f90 | 121 + examples/fortran/prima/sources.txt | 55 + examples/fortran/prima/tests/__init__.py | 1 + examples/fortran/prima/tests/test_solvers.py | 74 + 69 files changed, 28817 insertions(+) create mode 100644 examples/fortran/prima/CMakeLists.txt create mode 100644 examples/fortran/prima/LICENCE.txt create mode 100644 examples/fortran/prima/README.md create mode 100644 examples/fortran/prima/__init__.py create mode 100755 examples/fortran/prima/build_all.sh create mode 100755 examples/fortran/prima/build_prik.sh create mode 100644 examples/fortran/prima/conftest.py create mode 100644 examples/fortran/prima/export_symbols.txt create mode 100644 examples/fortran/prima/native/bobyqa/bobyqa.f90 create mode 100644 examples/fortran/prima/native/bobyqa/bobyqb.f90 create mode 100644 examples/fortran/prima/native/bobyqa/geometry.f90 create mode 100644 examples/fortran/prima/native/bobyqa/initialize.f90 create mode 100644 examples/fortran/prima/native/bobyqa/rescue.f90 create mode 100644 examples/fortran/prima/native/bobyqa/trustregion.f90 create mode 100644 examples/fortran/prima/native/bobyqa/update.f90 create mode 100644 examples/fortran/prima/native/cobyla/cobyla.f90 create mode 100644 examples/fortran/prima/native/cobyla/cobylb.f90 create mode 100644 examples/fortran/prima/native/cobyla/geometry.f90 create mode 100644 examples/fortran/prima/native/cobyla/initialize.f90 create mode 100644 examples/fortran/prima/native/cobyla/trustregion.f90 create mode 100644 examples/fortran/prima/native/cobyla/update.f90 create mode 100644 examples/fortran/prima/native/common/checkexit.f90 create mode 100644 examples/fortran/prima/native/common/consts.F90 create mode 100644 examples/fortran/prima/native/common/debug.F90 create mode 100644 examples/fortran/prima/native/common/evaluate.f90 create mode 100644 examples/fortran/prima/native/common/fprint.f90 create mode 100644 examples/fortran/prima/native/common/history.f90 create mode 100644 examples/fortran/prima/native/common/huge.F90 create mode 100644 examples/fortran/prima/native/common/inf.F90 create mode 100644 examples/fortran/prima/native/common/infnan.F90 create mode 100644 examples/fortran/prima/native/common/infos.f90 create mode 100644 examples/fortran/prima/native/common/linalg.f90 create mode 100644 examples/fortran/prima/native/common/memory.F90 create mode 100644 examples/fortran/prima/native/common/message.f90 create mode 100644 examples/fortran/prima/native/common/pintrf.f90 create mode 100644 examples/fortran/prima/native/common/powalg.f90 create mode 100644 examples/fortran/prima/native/common/ppf.h create mode 100644 examples/fortran/prima/native/common/preproc.f90 create mode 100644 examples/fortran/prima/native/common/ratio.f90 create mode 100644 examples/fortran/prima/native/common/redrho.f90 create mode 100644 examples/fortran/prima/native/common/selectx.f90 create mode 100644 examples/fortran/prima/native/common/shiftbase.f90 create mode 100644 examples/fortran/prima/native/common/string.f90 create mode 100644 examples/fortran/prima/native/common/univar.f90 create mode 100644 examples/fortran/prima/native/common/xinbd.f90 create mode 100644 examples/fortran/prima/native/lincoa/geometry.f90 create mode 100644 examples/fortran/prima/native/lincoa/getact.f90 create mode 100644 examples/fortran/prima/native/lincoa/initialize.f90 create mode 100644 examples/fortran/prima/native/lincoa/lincoa.f90 create mode 100644 examples/fortran/prima/native/lincoa/lincob.f90 create mode 100644 examples/fortran/prima/native/lincoa/trustregion.f90 create mode 100644 examples/fortran/prima/native/lincoa/update.f90 create mode 100644 examples/fortran/prima/native/newuoa/geometry.f90 create mode 100644 examples/fortran/prima/native/newuoa/initialize.f90 create mode 100644 examples/fortran/prima/native/newuoa/newuoa.f90 create mode 100644 examples/fortran/prima/native/newuoa/newuob.f90 create mode 100644 examples/fortran/prima/native/newuoa/trustregion.f90 create mode 100644 examples/fortran/prima/native/newuoa/update.f90 create mode 100644 examples/fortran/prima/native/uobyqa/geometry.f90 create mode 100644 examples/fortran/prima/native/uobyqa/initialize.f90 create mode 100644 examples/fortran/prima/native/uobyqa/trustregion.f90 create mode 100644 examples/fortran/prima/native/uobyqa/uobyqa.f90 create mode 100644 examples/fortran/prima/native/uobyqa/uobyqb.f90 create mode 100644 examples/fortran/prima/native/uobyqa/update.f90 create mode 100644 examples/fortran/prima/sources.txt create mode 100644 examples/fortran/prima/tests/__init__.py create mode 100644 examples/fortran/prima/tests/test_solvers.py diff --git a/CHANGELOG.md b/CHANGELOG.md index 4024cfc48..aff099d6b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,8 @@ release tags add a leading `v` to the package version. 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. - Forwardable Fortran optional arguments use a linear number of contained procedures and converge on one native call site instead of enumerating 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..c904b4b3c --- /dev/null +++ b/examples/fortran/prima/build_prik.sh @@ -0,0 +1,36 @@ +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 + +mapfile -t PRIMA_SOURCE_NAMES < "$EXAMPLE_WORKSPACE/examples/fortran/prima/sources.txt" +PRIMA_SOURCES=() +for source in "${PRIMA_SOURCE_NAMES[@]}"; do + PRIMA_SOURCES+=("$EXAMPLE_WORKSPACE/examples/fortran/prima/native/$source") +done + +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..4ff9566d8 --- /dev/null +++ b/examples/fortran/prima/tests/test_solvers.py @@ -0,0 +1,74 @@ +"""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 _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_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, ()) From 4145f96d098e22293e9286abafe21665e2aa573d Mon Sep 17 00:00:00 2001 From: said Date: Tue, 22 Sep 2026 21:35:20 +0100 Subject: [PATCH 3/6] codex: restrict Fortran exports to real modules --- docs/user/reference/cli-commands.md | 7 ++-- prik/cli.py | 11 ++--- prik/semantics/fortran_exports.py | 11 ++++- .../test_fortran_export_symbol_workflow.py | 41 +++++++++++++++++++ .../test_fortran_export_symbol_selection.py | 27 ++++++++++++ 5 files changed, 85 insertions(+), 12 deletions(-) diff --git a/docs/user/reference/cli-commands.md b/docs/user/reference/cli-commands.md index 275872b7c..ed27c4d10 100644 --- a/docs/user/reference/cli-commands.md +++ b/docs/user/reference/cli-commands.md @@ -402,9 +402,10 @@ cobyla_mod::cobyla ``` Qualification keeps procedures with the same spelling in different modules -distinct. 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. +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 diff --git a/prik/cli.py b/prik/cli.py index 3435c63e4..de50cfcd3 100644 --- a/prik/cli.py +++ b/prik/cli.py @@ -527,16 +527,13 @@ def _converted_semantic_files( from prik.semantics.fortran_exports import select_fortran_export_functions selection = select_fortran_export_functions(available_modules, export_symbols) - selected_by_module = { - str(module.origin.native_name or module.name).casefold(): module for module in selection.primary_modules + 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_module[name] - for module in modules - if (name := str(module.origin.native_name or module.name).casefold()) in selected_by_module - ] + 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) diff --git a/prik/semantics/fortran_exports.py b/prik/semantics/fortran_exports.py index c6793b418..f2d5f73a1 100644 --- a/prik/semantics/fortran_exports.py +++ b/prik/semantics/fortran_exports.py @@ -18,6 +18,7 @@ class FortranExportSelection: """Selected wrapper roots and the surrounding semantic source context.""" + primary_sources: tuple[SemanticModule, ...] primary_modules: tuple[SemanticModule, ...] context_modules: tuple[SemanticModule, ...] @@ -47,7 +48,11 @@ def select_fortran_export_functions( source modules remain available as context. Contract-import policy decides which of them the generated contract needs to emit. """ - source_modules = tuple(modules) + 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) @@ -55,6 +60,7 @@ def select_fortran_export_functions( 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) @@ -74,6 +80,7 @@ def select_fortran_export_functions( 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 @@ -83,7 +90,7 @@ def select_fortran_export_functions( # 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_modules), context_modules) + return FortranExportSelection(tuple(primary_sources), tuple(primary_modules), context_modules) def _validated_fortran_export_symbols(symbols: Iterable[str]) -> tuple[tuple[str, str], ...]: 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 index b7f476bb7..b9549ad79 100644 --- 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 @@ -59,6 +59,47 @@ def test_generate_pyi_emits_only_the_selected_module_and_callback_dependency(tmp 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( diff --git a/tests/fortran/functions/semantics/test_fortran_export_symbol_selection.py b/tests/fortran/functions/semantics/test_fortran_export_symbol_selection.py index b72d7dd86..109920806 100644 --- a/tests/fortran/functions/semantics/test_fortran_export_symbol_selection.py +++ b/tests/fortran/functions/semantics/test_fortran_export_symbol_selection.py @@ -7,6 +7,7 @@ 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, @@ -102,3 +103,29 @@ def test_selection_rejects_private_module_procedure(): 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"]) From 613de9ae2f61277d14cf579e03a7a6ceb06578c0 Mon Sep 17 00:00:00 2001 From: said Date: Tue, 22 Sep 2026 21:35:38 +0100 Subject: [PATCH 4/6] codex: validate PRIMA across real-library targets --- .../workflows/real-libraries-portability.yml | 4 ++ CHANGELOG.md | 3 +- README.md | 5 +- docs/developer/testing-strategy.md | 4 +- docs/developer/workflows/quality-assurance.md | 6 +-- docs/index.md | 7 +-- docs/user/examples/fortran/prima-wrapper.md | 50 +++++++++++++++++++ docs/user/examples/index.md | 8 +-- docs/user/faq/index.md | 7 +-- docs/user/index.md | 4 +- examples/fortran/prima/build_prik.sh | 5 +- examples/fortran/prima/tests/test_solvers.py | 14 ++++++ mkdocs.yml | 1 + tests/docs/test_examples.py | 1 + 14 files changed, 97 insertions(+), 22 deletions(-) create mode 100644 docs/user/examples/fortran/prima-wrapper.md 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 aff099d6b..840890237 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,7 +13,8 @@ release tags add a leading `v` to the package version. 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. + compiled `libprimaf` archive through a generated semantic contract and runs + in the real-library portability matrix. - Forwardable Fortran optional arguments use a linear number of contained procedures and converge on one native call site instead of enumerating 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..1dedd2e7d --- /dev/null +++ b/docs/user/examples/fortran/prima-wrapper.md @@ -0,0 +1,50 @@ +--- +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 source as a static library, generates a contract for five selected +optimization solvers, and links one Python extension against that library. + +Install PRIK with its example dependencies, CMake, and GNU Fortran. From the +repository root, build the extension and run its numerical checks: + +```bash +python3 -m pip install -e ".[qa]" +source examples/fortran/prima/build_all.sh +python3 -m pytest -q examples/fortran/prima/tests +``` + +The Python module exposes `bobyqa_mod.bobyqa`, `cobyla_mod.cobyla`, +`lincoa_mod.lincoa`, `newuoa_mod.newuoa`, and `uobyqa_mod.uobyqa`. For example: + +```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) +``` + +CMake compiles the 55 source files once into `libprimaf.a`. PRIK reads those +sources with [`export_symbols.txt`](../../../../examples/fortran/prima/export_symbols.txt), +emits the selected `.pyi` contracts and their callback dependency, then links +the wrapper to the archive. The contract's `__all__` controls the Python +surface. See the [project README](../../../../examples/fortran/prima/README.md) +for the source version and build details. + +The **Real Libraries Portability** workflow runs this build and its numerical +tests with Python 3.12 and GNU Fortran 13 on Linux x86-64, Linux ARM64, macOS +Intel, and macOS ARM64. 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 f1a7ec086..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). 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/examples/fortran/prima/build_prik.sh b/examples/fortran/prima/build_prik.sh index c904b4b3c..ddd54e90b 100755 --- a/examples/fortran/prima/build_prik.sh +++ b/examples/fortran/prima/build_prik.sh @@ -10,11 +10,10 @@ cmake \ -DCMAKE_Fortran_COMPILER="$(command -v gfortran)" cmake --build "$PRIMA_BUILD_ROOT/native" --target primaf --parallel 2 -mapfile -t PRIMA_SOURCE_NAMES < "$EXAMPLE_WORKSPACE/examples/fortran/prima/sources.txt" PRIMA_SOURCES=() -for source in "${PRIMA_SOURCE_NAMES[@]}"; do +while IFS= read -r source; do PRIMA_SOURCES+=("$EXAMPLE_WORKSPACE/examples/fortran/prima/native/$source") -done +done < "$EXAMPLE_WORKSPACE/examples/fortran/prima/sources.txt" python3 -m prik generate --pyi \ "${PRIMA_SOURCES[@]}" \ diff --git a/examples/fortran/prima/tests/test_solvers.py b/examples/fortran/prima/tests/test_solvers.py index 4ff9566d8..caebb3e45 100644 --- a/examples/fortran/prima/tests/test_solvers.py +++ b/examples/fortran/prima/tests/test_solvers.py @@ -9,6 +9,20 @@ 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 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/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")), From 29106df10f131c92baff0ad07978a378ea91d78c Mon Sep 17 00:00:00 2001 From: said Date: Tue, 22 Sep 2026 23:19:46 +0100 Subject: [PATCH 5/6] codex: make PRIMA guide reproducible with SciPy cross-check --- CHANGELOG.md | 3 +- docs/user/examples/fortran/prima-wrapper.md | 120 ++++++++++++++++--- examples/fortran/prima/tests/test_solvers.py | 23 ++++ 3 files changed, 130 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 840890237..221d2079f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,7 +14,8 @@ release tags add a leading `v` to the package version. 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. + in the real-library portability matrix. Its guide includes a reproducible + build, runnable solver example, and optional SciPy COBYLA cross-check. - Forwardable Fortran optional arguments use a linear number of contained procedures and converge on one native call site instead of enumerating diff --git a/docs/user/examples/fortran/prima-wrapper.md b/docs/user/examples/fortran/prima-wrapper.md index 1dedd2e7d..8df0dd229 100644 --- a/docs/user/examples/fortran/prima-wrapper.md +++ b/docs/user/examples/fortran/prima-wrapper.md @@ -9,23 +9,65 @@ publication: reviewed # Build and Validate PRIMA with PRIK -This example builds the checked-in [libPRIMA](https://github.com/libprima/prima) -Fortran source as a static library, generates a contract for five selected -optimization solvers, and links one Python extension against that library. +Build the checked-in [libPRIMA](https://github.com/libprima/prima) Fortran +sources once, wrap five derivative-free solvers with PRIK, and try them from +Python. The example includes runnable numerical tests and an optional SciPy +comparison for COBYLA. -Install PRIK with its example dependencies, CMake, and GNU Fortran. From the -repository root, build the extension and run its numerical checks: +## 1. Prepare the repository and toolchain + +You need Python, CMake, a C compiler, and GNU Fortran. The portability job +uses Python 3.12, NumPy 2.5.1, GCC/GNU Fortran 13, and SciPy 1.18.0 for the +optional comparison. A compatible local toolchain also works. + +On Ubuntu, install the native tools: ```bash +sudo apt-get update +sudo apt-get install --yes cmake gcc gfortran +``` + +Clone PRIK and install its test dependencies in a virtual environment: + +```bash +git clone https://github.com/PyNumLab/prik.git +cd prik +python3 -m venv .venv +. .venv/bin/activate python3 -m pip install -e ".[qa]" +``` + +Run the remaining commands from the repository root in this same shell. + +## 2. Build the library and Python extension + +```bash source examples/fortran/prima/build_all.sh -python3 -m pytest -q examples/fortran/prima/tests ``` -The Python module exposes `bobyqa_mod.bobyqa`, `cobyla_mod.cobyla`, -`lincoa_mod.lincoa`, `newuoa_mod.newuoa`, and `uobyqa_mod.uobyqa`. For example: +Source the script rather than executing it in a new shell: it leaves the built +extension on `PYTHONPATH` and records its temporary location in +`PRIMA_BUILD_ROOT`. CMake compiles the 55 native sources into `libprimaf.a`; +PRIK analyzes those sources, writes the selected `.pyi` contract, and links +its wrapper to that archive without recompiling PRIMA. + +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` | -```python +## 3. Solve a problem + +Run this from the same shell. UOBYQA minimizes a two-variable quadratic whose +known minimum is at `(1, -2)`: + +```bash +python3 - <<'PY' import numpy as np import prik_prima @@ -36,15 +78,63 @@ def objective(values, result): 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) +PY +``` + +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 and adapt the tests + +Run every selected solver and the callback checks: + +```bash +python3 -m pytest -q examples/fortran/prima/tests +``` + +For a faster edit/test cycle, run one solver test: + +```bash +python3 -m pytest -q examples/fortran/prima/tests/test_solvers.py::test_lincoa_minimizes_a_quadratic ``` -CMake compiles the 55 source files once into `libprimaf.a`. PRIK reads those -sources with [`export_symbols.txt`](../../../../examples/fortran/prima/export_symbols.txt), -emits the selected `.pyi` contracts and their callback dependency, then links -the wrapper to the archive. The contract's `__all__` controls the Python -surface. See the [project README](../../../../examples/fortran/prima/README.md) -for the source version and build details. +The checked-in [`test_solvers.py`](../../../../examples/fortran/prima/tests/test_solvers.py) +is a starting point for your own cases. Add a `test_*` function in that file, +or add another `test_*.py` 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. The suite covers a numerical +case for each of the five exposed solvers and checks both present and omitted +optional callback arguments; it is not an exhaustive solver-option or +constraint suite. + +SciPy is optional. Install it to run the additional COBYLA comparison: + +```bash +python3 -m pip install scipy +python3 -m pytest -q examples/fortran/prima/tests/test_solvers.py::test_cobyla_agrees_with_scipy_on_a_quadratic +``` + +This compares the two COBYLA results with the known mathematical solution; it +does not measure speed. SciPy's +[COBYLA method](https://docs.scipy.org/doc/scipy/reference/optimize.minimize-cobyla.html) +is the direct counterpart among the five exposed solvers. The other four are +checked against the known minimum without requiring SciPy. + +## Build inputs and platforms + +The checked-in [`export_symbols.txt`](../../../../examples/fortran/prima/export_symbols.txt) +selects the five solver procedures. PRIK keeps the callback declarations +their signatures need in the generated contract. Both the native library and +contract extraction use 64-bit real values and the default PRIMA integer kind. +See the [example README](../../../../examples/fortran/prima/README.md) and +[build script](../../../../examples/fortran/prima/build_prik.sh) to adapt the +build for another project. The **Real Libraries Portability** workflow runs this build and its numerical tests with Python 3.12 and GNU Fortran 13 on Linux x86-64, Linux ARM64, macOS Intel, and macOS ARM64. + +The sources under [`native/`](../../../../examples/fortran/prima/native/) are +from [libPRIMA commit `1d76fb88aeffb427cd17ed1e9d0d3b34f414913f`](https://github.com/libprima/prima/tree/1d76fb88aeffb427cd17ed1e9d0d3b34f414913f) +and retain its [BSD 3-Clause license](../../../../examples/fortran/prima/LICENCE.txt). diff --git a/examples/fortran/prima/tests/test_solvers.py b/examples/fortran/prima/tests/test_solvers.py index caebb3e45..17fd3a9c2 100644 --- a/examples/fortran/prima/tests/test_solvers.py +++ b/examples/fortran/prima/tests/test_solvers.py @@ -75,6 +75,29 @@ def progress(values, f, nf, tr, cstrv, nlconstr, terminate): 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 = [] From 401054a908edf7d33bbb3293fee9c5334a11ec46 Mon Sep 17 00:00:00 2001 From: said Date: Wed, 23 Sep 2026 00:18:02 +0100 Subject: [PATCH 6/6] codex: align PRIMA guide with maintained examples --- CHANGELOG.md | 3 +- docs/user/examples/fortran/prima-wrapper.md | 267 +++++++++++++++----- 2 files changed, 203 insertions(+), 67 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 221d2079f..fdd7f815e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,7 +15,8 @@ release tags add a leading `v` to the package version. - 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, runnable solver example, and optional SciPy COBYLA cross-check. + 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 diff --git a/docs/user/examples/fortran/prima-wrapper.md b/docs/user/examples/fortran/prima-wrapper.md index 8df0dd229..20fd4fe91 100644 --- a/docs/user/examples/fortran/prima-wrapper.md +++ b/docs/user/examples/fortran/prima-wrapper.md @@ -9,47 +9,140 @@ publication: reviewed # Build and Validate PRIMA with PRIK -Build the checked-in [libPRIMA](https://github.com/libprima/prima) Fortran -sources once, wrap five derivative-free solvers with PRIK, and try them from -Python. The example includes runnable numerical tests and an optional SciPy -comparison for COBYLA. +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 -You need Python, CMake, a C compiler, and GNU Fortran. The portability job -uses Python 3.12, NumPy 2.5.1, GCC/GNU Fortran 13, and SciPy 1.18.0 for the -optional comparison. A compatible local toolchain also works. +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" +``` -On Ubuntu, install the native tools: +Install CMake and GNU Fortran separately. On Ubuntu: ```bash sudo apt-get update sudo apt-get install --yes cmake gcc gfortran +gfortran --version ``` -Clone PRIK and install its test dependencies in a virtual environment: +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 -git clone https://github.com/PyNumLab/prik.git -cd prik -python3 -m venv .venv -. .venv/bin/activate -python3 -m pip install -e ".[qa]" +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 ``` -Run the remaining commands from the repository root in this same shell. +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. -## 2. Build the library and Python extension +For normal use, source the convenience entrypoint: ```bash source examples/fortran/prima/build_all.sh ``` -Source the script rather than executing it in a new shell: it leaves the built -extension on `PYTHONPATH` and records its temporary location in -`PRIMA_BUILD_ROOT`. CMake compiles the 55 native sources into `libprimaf.a`; -PRIK analyzes those sources, writes the selected `.pyi` contract, and links -its wrapper to that archive without recompiling PRIMA. +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: @@ -61,13 +154,10 @@ The public Python API has exactly these entries: | `newuoa_mod` | `newuoa` | | `uobyqa_mod` | `uobyqa` | -## 3. Solve a problem +For example, UOBYQA minimizes a two-variable quadratic whose known minimum is +at `(1, -2)`. After building the extension, run this in Python: -Run this from the same shell. UOBYQA minimizes a two-variable quadratic whose -known minimum is at `(1, -2)`: - -```bash -python3 - <<'PY' +```python import numpy as np import prik_prima @@ -79,62 +169,107 @@ def objective(values, result): 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) -PY ``` 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 and adapt the tests +--- + +## 4. Run the complete test suite -Run every selected solver and the callback checks: +After the build finishes, run: ```bash python3 -m pytest -q examples/fortran/prima/tests ``` -For a faster edit/test cycle, run one solver test: +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. -```bash -python3 -m pytest -q examples/fortran/prima/tests/test_solvers.py::test_lincoa_minimizes_a_quadratic +--- + +## 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,), ()) ``` -The checked-in [`test_solvers.py`](../../../../examples/fortran/prima/tests/test_solvers.py) -is a starting point for your own cases. Add a `test_*` function in that file, -or add another `test_*.py` 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. The suite covers a numerical -case for each of the five exposed solvers and checks both present and omitted -optional callback arguments; it is not an exhaustive solver-option or -constraint suite. +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 -SciPy is optional. Install it to run the additional COBYLA comparison: +After building the extension, run one solver test or the optional SciPy +comparison: ```bash -python3 -m pip install scipy +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 ``` -This compares the two COBYLA results with the known mathematical solution; it -does not measure speed. SciPy's -[COBYLA method](https://docs.scipy.org/doc/scipy/reference/optimize.minimize-cobyla.html) -is the direct counterpart among the five exposed solvers. The other four are -checked against the known minimum without requiring SciPy. - -## Build inputs and platforms - -The checked-in [`export_symbols.txt`](../../../../examples/fortran/prima/export_symbols.txt) -selects the five solver procedures. PRIK keeps the callback declarations -their signatures need in the generated contract. Both the native library and -contract extraction use 64-bit real values and the default PRIMA integer kind. -See the [example README](../../../../examples/fortran/prima/README.md) and -[build script](../../../../examples/fortran/prima/build_prik.sh) to adapt the -build for another project. - -The **Real Libraries Portability** workflow runs this build and its numerical -tests with Python 3.12 and GNU Fortran 13 on Linux x86-64, Linux ARM64, macOS -Intel, and macOS ARM64. - -The sources under [`native/`](../../../../examples/fortran/prima/native/) are -from [libPRIMA commit `1d76fb88aeffb427cd17ed1e9d0d3b34f414913f`](https://github.com/libprima/prima/tree/1d76fb88aeffb427cd17ed1e9d0d3b34f414913f) -and retain its [BSD 3-Clause license](../../../../examples/fortran/prima/LICENCE.txt). +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).