diff -Nru libctl-4.4.0/AUTHORS libctl-4.5.0/AUTHORS --- libctl-4.4.0/AUTHORS 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/AUTHORS 2020-02-19 18:34:33.000000000 +0000 @@ -3,6 +3,7 @@ M.T. Homer Reid Christopher Hogan Ardavan Oskooi +Daniel W. Boyce The multidimensional integration routines in src/integrator.c were adapted from the HIntlib Library by Rudolf Schuerer and from the GNU Scientific diff -Nru libctl-4.4.0/base/class.scm libctl-4.5.0/base/class.scm --- libctl-4.4.0/base/class.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/class.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/ctl.scm libctl-4.5.0/base/ctl.scm --- libctl-4.4.0/base/ctl.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/ctl.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/extern-funcs.scm libctl-4.5.0/base/extern-funcs.scm --- libctl-4.4.0/base/extern-funcs.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/extern-funcs.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/help.scm libctl-4.5.0/base/help.scm --- libctl-4.4.0/base/help.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/help.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/include.scm libctl-4.5.0/base/include.scm --- libctl-4.4.0/base/include.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/include.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/interaction.scm libctl-4.5.0/base/interaction.scm --- libctl-4.4.0/base/interaction.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/interaction.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/io-vars.scm libctl-4.5.0/base/io-vars.scm --- libctl-4.4.0/base/io-vars.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/io-vars.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/main.c libctl-4.5.0/base/main.c --- libctl-4.4.0/base/main.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/main.c 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2014 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This file may be used without restriction. It is in the public * domain, and is NOT restricted by the terms of any GNU license. @@ -54,101 +54,98 @@ Also return, in spec_file_loaded, whether we have loaded the specifications file due to a command-line arg. Also return, in continue_run, whether or not to continue the run. */ -int handle_args(int argc, char *argv[], - boolean *spec_file_loaded, boolean *continue_run) -{ - int i; - - *continue_run = 1; - *spec_file_loaded = 0; - - for (i = 1; i < argc; ++i) { - if (argv[i][0] != '-') - break; - if (!strcmp(argv[i], "--version") || !strcmp(argv[i], "-V")) { - if (!libctl_quiet) { - char *guile_vers; +int handle_args(int argc, char *argv[], boolean *spec_file_loaded, boolean *continue_run) { + int i; + + *continue_run = 1; + *spec_file_loaded = 0; + + for (i = 1; i < argc; ++i) { + if (argv[i][0] != '-') break; + if (!strcmp(argv[i], "--version") || !strcmp(argv[i], "-V")) { + if (!libctl_quiet) { + char *guile_vers; #ifdef VERSION_STRING - /* print version string, if defined: */ - printf(VERSION_STRING); + /* print version string, if defined: */ + printf(VERSION_STRING); #endif #ifdef LIBCTL_VERSION - printf("\nUsing libctl %s", LIBCTL_VERSION); + printf("\nUsing libctl %s", LIBCTL_VERSION); #else - printf("\nUsing libctl"); + printf("\nUsing libctl"); #endif - guile_vers = ctl_convert_string_to_c( - gh_eval_str("(version)")); - printf(" and Guile %s.\n", guile_vers); - free(guile_vers); - } - *continue_run = 0; - } - else if (!strcmp(argv[i], "--verbose") || !strcmp(argv[i], "-v")) - verbose = 1; - else if (!strncmp(argv[i], "--spec-file=", strlen("--spec-file="))) { - ctl_include(argv[i] + strlen("--spec-file=")); - *spec_file_loaded = 1; - } - else if (!strcmp(argv[i], "--help") || !strcmp(argv[i], "-h")) { - char *slash = strrchr(argv[0], '/'); - if (!libctl_quiet) - printf("Usage: %s [options] [definitions] [ctl files]\n" - "options:\n" - " --help, -h: this help\n" - " --version, -V: display version information\n" - " --verbose, -v: enable verbose output\n" - " --spec-file=: use for spec. file\n" - "definitions: assignments of the form " - "=\n" - "ctl files: zero or more Scheme/ctl files to execute\n", - slash ? slash + 1 : argv[0]); - *continue_run = 0; - } - else { - if (!libctl_quiet) - fprintf(stderr, "Unknown option %s! Use the --help option" - " for more information.\n", argv[i]); - exit(EXIT_FAILURE); - } - } + guile_vers = ctl_convert_string_to_c(gh_eval_str("(version)")); + printf(" and Guile %s.\n", guile_vers); + free(guile_vers); + } + *continue_run = 0; + } + else if (!strcmp(argv[i], "--verbose") || !strcmp(argv[i], "-v")) + verbose = 1; + else if (!strncmp(argv[i], "--spec-file=", strlen("--spec-file="))) { + ctl_include(argv[i] + strlen("--spec-file=")); + *spec_file_loaded = 1; + } + else if (!strcmp(argv[i], "--help") || !strcmp(argv[i], "-h")) { + char *slash = strrchr(argv[0], '/'); + if (!libctl_quiet) + printf("Usage: %s [options] [definitions] [ctl files]\n" + "options:\n" + " --help, -h: this help\n" + " --version, -V: display version information\n" + " --verbose, -v: enable verbose output\n" + " --spec-file=: use for spec. file\n" + "definitions: assignments of the form " + "=\n" + "ctl files: zero or more Scheme/ctl files to execute\n", + slash ? slash + 1 : argv[0]); + *continue_run = 0; + } + else { + if (!libctl_quiet) + fprintf(stderr, + "Unknown option %s! Use the --help option" + " for more information.\n", + argv[i]); + exit(EXIT_FAILURE); + } + } - return i; + return i; } /**************************************************************************/ -static int exists(const char *fname) -{ - FILE *f = fopen(fname, "r"); - if (f) { - fclose(f); - return 1; - } - return 0; +static int exists(const char *fname) { + FILE *f = fopen(fname, "r"); + if (f) { + fclose(f); + return 1; + } + return 0; } -static char *make_name(const char *for_dir, const char *for_base) -{ - char *dir0, *dir, *base0, *base, *name = 0; - size_t ndir; - dir0 = (char *) malloc(sizeof(char) * (strlen(for_dir) + 1)); - base0 = (char *) malloc(sizeof(char) * (strlen(for_base) + 1)); - strcpy(dir0, for_dir); dir = dirname(dir0); - ndir = strlen(dir); - if (ndir > 0) { - if (ndir > 5 && !strcmp(".libs", dir+ndir-5)) - dir[ndir-5] = 0; /* ignore ".libs" directory suffix from libtool */ - strcpy(base0, for_base); base = basename(base0); - name = (char *) malloc(sizeof(char) * (strlen(dir) + 1 + - strlen(base) + 1)); - strcpy(name, dir); - strcat(name, "/"); - strcat(name, base); - free(base0); - } - free(dir0); - return name; +static char *make_name(const char *for_dir, const char *for_base) { + char *dir0, *dir, *base0, *base, *name = 0; + size_t ndir; + dir0 = (char *)malloc(sizeof(char) * (strlen(for_dir) + 1)); + base0 = (char *)malloc(sizeof(char) * (strlen(for_base) + 1)); + strcpy(dir0, for_dir); + dir = dirname(dir0); + ndir = strlen(dir); + if (ndir > 0) { + if (ndir > 5 && !strcmp(".libs", dir + ndir - 5)) + dir[ndir - 5] = 0; /* ignore ".libs" directory suffix from libtool */ + strcpy(base0, for_base); + base = basename(base0); + name = (char *)malloc(sizeof(char) * (strlen(dir) + 1 + strlen(base) + 1)); + strcpy(name, dir); + strcat(name, "/"); + strcat(name, base); + free(base0); + } + free(dir0); + return name; } /**************************************************************************/ @@ -164,12 +161,8 @@ extern void ctl_export_hook(void); #endif -extern SCM nlopt_minimize_scm(SCM algorithm_scm, - SCM f_scm, - SCM lb_scm, SCM ub_scm, SCM x_scm, - SCM minf_max_scm, SCM ftol_rel_scm, SCM ftol_abs_scm, - SCM rest); - +extern SCM nlopt_minimize_scm(SCM algorithm_scm, SCM f_scm, SCM lb_scm, SCM ub_scm, SCM x_scm, + SCM minf_max_scm, SCM ftol_rel_scm, SCM ftol_abs_scm, SCM rest); /* Main program. Start up Guile, declare functions, load any scripts passed on the command-line, and drop into interactive @@ -177,15 +170,14 @@ void main_entry( #ifdef HAVE_NO_GH - void *main_entry_data, /* unused, required by scm_boot_guile */ + void *main_entry_data, /* unused, required by scm_boot_guile */ #endif - int argc, char *argv[]) -{ + int argc, char *argv[]) { int i; boolean spec_file_loaded, continue_run; SCM interactive; #ifdef HAVE_NO_GH - (void) main_entry_data; /* unused */ + (void)main_entry_data; /* unused */ #endif /* Notify Guile of functions that we are making callable from Scheme. @@ -195,25 +187,22 @@ /* Also export the read_input_vars and write_output_vars routines that are automatically generated from the specifications file: */ - gh_new_procedure ("read-input-vars", read_input_vars, 0, 0, 0); - gh_new_procedure ("write-output-vars", write_output_vars, 0, 0, 0); + gh_new_procedure("read-input-vars", read_input_vars, 0, 0, 0); + gh_new_procedure("write-output-vars", write_output_vars, 0, 0, 0); /* Export the subplex minimization routine: */ - gh_new_procedure ("subplex", (SCM (*)(void)) subplex_scm, 7, 0, 0); + gh_new_procedure("subplex", (SCM(*)(void))subplex_scm, 7, 0, 0); #ifdef HAVE_NLOPT /* Export the nlopt minimization routine, if available: */ - gh_new_procedure ("nlopt-minimize", (SCM (*)(void)) nlopt_minimize_scm, - 8, 0, 1); + gh_new_procedure("nlopt-minimize", (SCM(*)(void))nlopt_minimize_scm, 8, 0, 1); #endif /* Export the adaptive integration routines: */ - gh_new_procedure ("adaptive-integration", - (SCM (*)(void)) adaptive_integration_scm, 6, 0, 0); + gh_new_procedure("adaptive-integration", (SCM(*)(void))adaptive_integration_scm, 6, 0, 0); #ifdef CTL_HAS_COMPLEX_INTEGRATION - gh_new_procedure ("cadaptive-integration", - (SCM (*)(void)) cadaptive_integration_scm, 6, 0, 0); + gh_new_procedure("cadaptive-integration", (SCM(*)(void))cadaptive_integration_scm, 6, 0, 0); #endif #ifdef HAVE_CTL_EXPORT_HOOK @@ -233,64 +222,64 @@ i = handle_args(argc, argv, &spec_file_loaded, &continue_run); { - char definestr[] = "(define verbose? false)"; - strcpy(definestr, "(define verbose? "); - strcat(definestr, verbose ? "true)" : "false)"); - gh_eval_str(definestr); + char definestr[] = "(define verbose? false)"; + strcpy(definestr, "(define verbose? "); + strcat(definestr, verbose ? "true)" : "false)"); + gh_eval_str(definestr); } - if (!continue_run) - goto done; + if (!continue_run) goto done; - /* load the specification file if it was given at compile time, - and if it wasn't specified on the command-line: */ + /* load the specification file if it was given at compile time, + and if it wasn't specified on the command-line: */ #ifdef SPEC_SCM if (!spec_file_loaded) { - /* try first to load it in the program directory if it - was specified explicitly (e.g. "./foo"), for cases - where we are running a program that has not been installed */ - char *spec_name = make_name(argv[0], SPEC_SCM); - if (spec_name && exists(spec_name)) - ctl_include(spec_name); - else - ctl_include(SPEC_SCM); - free(spec_name); + /* try first to load it in the program directory if it + was specified explicitly (e.g. "./foo"), for cases + where we are running a program that has not been installed */ + char *spec_name = make_name(argv[0], SPEC_SCM); + if (spec_name && exists(spec_name)) + ctl_include(spec_name); + else + ctl_include(SPEC_SCM); + free(spec_name); } #endif /* define any variables and load any scheme files specified on the command line: */ for (; i < argc; ++i) { - if (strchr(argv[i],'=')) { + if (strchr(argv[i], '=')) { char *eq; - char *definestr = (char*) malloc(sizeof(char) * (strlen("(define ") + - strlen(argv[i]) + 2)); + char *definestr = (char *)malloc(sizeof(char) * (strlen("(define ") + strlen(argv[i]) + 2)); if (!definestr) { - fprintf(stderr, __FILE__ ": out of memory!\n"); - exit(EXIT_FAILURE); + fprintf(stderr, __FILE__ ": out of memory!\n"); + exit(EXIT_FAILURE); } - strcpy(definestr,"(define "); - strcat(definestr,argv[i]); - strcat(definestr,")"); - eq = strchr(definestr,'='); + strcpy(definestr, "(define "); + strcat(definestr, argv[i]); + strcat(definestr, ")"); + eq = strchr(definestr, '='); *eq = ' '; if (!libctl_quiet) printf("command-line param: %s\n", argv[i]); gh_eval_str(definestr); { /* add the name of the defined variable to params-set-list */ - char *remember_define; - strcpy(definestr,argv[i]); - eq = strchr(definestr,'='); - *eq = 0; - remember_define = (char*) malloc(sizeof(char) * (strlen("(set! params-set-list (cons (quote x) params-set-list))") + strlen(definestr))); - if (!remember_define) { - fprintf(stderr, __FILE__ ": out of memory!\n"); - exit(EXIT_FAILURE); - } - strcpy(remember_define, "(set! params-set-list (cons (quote "); - strcat(remember_define, definestr); - strcat(remember_define, ") params-set-list))"); - gh_eval_str(remember_define); - free(remember_define); + char *remember_define; + strcpy(definestr, argv[i]); + eq = strchr(definestr, '='); + *eq = 0; + remember_define = (char *)malloc( + sizeof(char) * (strlen("(set! params-set-list (cons (quote x) params-set-list))") + + strlen(definestr))); + if (!remember_define) { + fprintf(stderr, __FILE__ ": out of memory!\n"); + exit(EXIT_FAILURE); + } + strcpy(remember_define, "(set! params-set-list (cons (quote "); + strcat(remember_define, definestr); + strcat(remember_define, ") params-set-list))"); + gh_eval_str(remember_define); + free(remember_define); } free(definestr); argv[i][0] = 0; @@ -304,11 +293,9 @@ defined. */ interactive = gh_lookup("interactive?"); - if (interactive != SCM_BOOL_F) - gh_repl(argc - i, argv + i); /* skip already-handled args */ + if (interactive != SCM_BOOL_F) gh_repl(argc - i, argv + i); /* skip already-handled args */ - done: - ; +done:; #ifdef HAVE_CTL_HOOKS /* Note that the stop hook will never be called if we are in interactive mode, because gh_repl calls exit(). Oh well. */ @@ -317,19 +304,17 @@ #endif } -int main (int argc, char *argv[]) -{ +int main(int argc, char *argv[]) { #ifdef HAVE_CTL_HOOKS ctl_start_hook(&argc, &argv); #endif #ifdef HAVE_NO_GH - scm_boot_guile (argc, argv, main_entry, NULL); + scm_boot_guile(argc, argv, main_entry, NULL); #else - gh_enter (argc, argv, main_entry); + gh_enter(argc, argv, main_entry); #endif #ifdef HAVE_CTL_HOOKS - if (!ctl_stop_hook_called) - ctl_stop_hook(); + if (!ctl_stop_hook_called) ctl_stop_hook(); #endif return EXIT_SUCCESS; } diff -Nru libctl-4.4.0/base/math-utils.scm libctl-4.5.0/base/math-utils.scm --- libctl-4.4.0/base/math-utils.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/math-utils.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/matrix3x3.scm libctl-4.5.0/base/matrix3x3.scm --- libctl-4.4.0/base/matrix3x3.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/matrix3x3.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/simplex.scm libctl-4.5.0/base/simplex.scm --- libctl-4.4.0/base/simplex.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/simplex.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/utils.scm libctl-4.5.0/base/utils.scm --- libctl-4.4.0/base/utils.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/utils.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/base/vector3.scm libctl-4.5.0/base/vector3.scm --- libctl-4.4.0/base/vector3.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/base/vector3.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/.clang-format libctl-4.5.0/.clang-format --- libctl-4.4.0/.clang-format 1970-01-01 00:00:00.000000000 +0000 +++ libctl-4.5.0/.clang-format 2020-02-19 18:34:33.000000000 +0000 @@ -0,0 +1,24 @@ +BasedOnStyle: LLVM +IndentWidth: 2 +UseTab: Never +IndentCaseLabels: true +AllowShortBlocksOnASingleLine: true +AllowShortCaseLabelsOnASingleLine: true +AllowShortIfStatementsOnASingleLine: true +AllowShortFunctionsOnASingleLine: true +ColumnLimit: 100 +Standard: Cpp03 +SortIncludes: false +BreakBeforeBraces: Custom +BraceWrapping: + AfterClass: false + AfterControlStatement: false + AfterEnum: false + AfterFunction: false + AfterNamespace: false + AfterObjCDeclaration: false + AfterStruct: false + AfterUnion: false + BeforeCatch: true + BeforeElse: true + IndentBraces: false diff -Nru libctl-4.4.0/configure.ac libctl-4.5.0/configure.ac --- libctl-4.4.0/configure.ac 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/configure.ac 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ # Process this file with autoconf to produce a configure script. -AC_INIT(libctl, 4.4.0, stevenj@alum.mit.edu) +AC_INIT(libctl, 4.5.0, stevenj@alum.mit.edu) AC_CONFIG_SRCDIR([src/ctl.c]) AC_CONFIG_HEADERS([config.h src/ctl.h]) AC_CONFIG_MACRO_DIR([m4]) @@ -8,7 +8,7 @@ # Shared-library version number; indicates api compatibility, and is # not the same as the "public" version number. (Don't worry about this # except for public releases.) -SHARED_VERSION_INFO="9:0:2" # CURRENT:REVISION:AGE +SHARED_VERSION_INFO="10:0:3" # CURRENT:REVISION:AGE AM_INIT_AUTOMAKE([foreign]) AC_SUBST(SHARED_VERSION_INFO) @@ -29,6 +29,9 @@ AC_DEFINE_UNQUOTED(LIBCTL_MAJOR_VERSION, $LIBCTL_MAJOR_VERSION, [major v.]) AC_DEFINE_UNQUOTED(LIBCTL_MINOR_VERSION, $LIBCTL_MINOR_VERSION, [minor v.]) AC_DEFINE_UNQUOTED(LIBCTL_BUGFIX_VERSION, $LIBCTL_BUGFIX_VERSION, [bugfix v.]) +AC_SUBST(LIBCTL_MAJOR_VERSION) +AC_SUBST(LIBCTL_MINOR_VERSION) +AC_SUBST(LIBCTL_BUGFIX_VERSION) ########################################################################### diff -Nru libctl-4.4.0/COPYRIGHT libctl-4.5.0/COPYRIGHT --- libctl-4.4.0/COPYRIGHT 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/COPYRIGHT 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/debian/changelog libctl-4.5.0/debian/changelog --- libctl-4.4.0/debian/changelog 2019-12-02 19:25:46.000000000 +0000 +++ libctl-4.5.0/debian/changelog 2020-04-12 21:25:02.000000000 +0000 @@ -1,3 +1,29 @@ +libctl (4.5.0-4) unstable; urgency=medium + + * bad test, so disable all tests + + -- Thorsten Alteholz Sun, 12 Apr 2020 23:25:02 +0200 + +libctl (4.5.0-3) unstable; urgency=medium + + * bad test, so disable tests on more architectures + + -- Thorsten Alteholz Sun, 12 Apr 2020 19:25:02 +0200 + +libctl (4.5.0-2) unstable; urgency=medium + + * source upload + + -- Thorsten Alteholz Sat, 11 Apr 2020 19:25:02 +0200 + +libctl (4.5.0-1) unstable; urgency=medium + + * New upstream release + * debian/control: bump standard to 4.5.0 (no change) + * debian/control: use dh12 + + -- Thorsten Alteholz Wed, 11 Mar 2020 22:25:02 +0000 + libctl (4.4.0-3) unstable; urgency=medium * upload to unstable diff -Nru libctl-4.4.0/debian/compat libctl-4.5.0/debian/compat --- libctl-4.4.0/debian/compat 2018-02-07 18:18:40.000000000 +0000 +++ libctl-4.5.0/debian/compat 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -11 diff -Nru libctl-4.4.0/debian/control libctl-4.5.0/debian/control --- libctl-4.4.0/debian/control 2019-10-07 18:06:46.000000000 +0000 +++ libctl-4.5.0/debian/control 2020-03-11 22:25:02.000000000 +0000 @@ -2,10 +2,10 @@ Section: devel Priority: optional Maintainer: Thorsten Alteholz -Build-Depends: debhelper (>= 11) +Build-Depends: debhelper-compat (= 12) , guile-2.2-dev , gfortran -Standards-Version: 4.4.1 +Standards-Version: 4.5.0 Homepage: http://ab-initio.mit.edu/wiki/index.php/Libctl Vcs-Browser: https://salsa.debian.org/alteholz/libctl Vcs-Git: https://salsa.debian.org/alteholz/libctl.git diff -Nru libctl-4.4.0/debian/libctl7.symbols libctl-4.5.0/debian/libctl7.symbols --- libctl-4.4.0/debian/libctl7.symbols 2019-11-20 18:25:46.000000000 +0000 +++ libctl-4.5.0/debian/libctl7.symbols 2020-03-11 22:25:02.000000000 +0000 @@ -219,6 +219,8 @@ geometry@Base 4.1.0 geometry_center@Base 4.1.0 geometry_lattice@Base 4.1.0 + get_area_of_polygon_from_nodes@Base 4.5.0 + get_volume_irregular_triangular_prism@Base 4.5.0 intersect_line_segment_with_object@Base 4.1.0 intersect_line_with_object@Base 4.1.0 intersect_line_with_prism@Base 4.1.0 @@ -238,6 +240,8 @@ make_hermitian_cmatrix3x3@Base 4.1.0 make_prism@Base 4.1.0 make_prism_with_center@Base 4.3.0 + make_slanted_prism@Base 4.5.0 + make_slanted_prism_with_center@Base 4.5.0 make_sphere@Base 4.1.0 make_wedge@Base 4.1.0 material_of_point0@Base 4.1.0 @@ -285,6 +289,7 @@ range_overlap_with_object@Base 4.1.0 restrict_geom_box_tree@Base 4.1.0 shift_to_unit_cell@Base 4.1.0 + sidewall_scaling_matrix@Base 4.5.0 sphere_copy@Base 4.1.0 sphere_destroy@Base 4.1.0 sphere_equal@Base 4.1.0 diff -Nru libctl-4.4.0/debian/rules libctl-4.5.0/debian/rules --- libctl-4.4.0/debian/rules 2019-12-01 14:25:46.000000000 +0000 +++ libctl-4.5.0/debian/rules 2020-04-12 21:25:02.000000000 +0000 @@ -37,13 +37,17 @@ override_dh_auto_test: ifeq (,$(filter nocheck,$(DEB_BUILD_OPTIONS))) + # unless upstream issue is resolved, all architectures + # need to be excluded here + # -> https://github.com/NanoComp/libctl/issues/41 echo ${arch} - if [ "${arch}" = "i386" ] || \ - [ "${arch}" = "s390x" ] || \ - [ "${arch}" = "powerpc" ] ; then \ - echo "Do not make tests on this architecture" ;\ - else \ - echo "Do make tests on this architecture" ;\ - make -j4 check VERBOSE=1 ;\ - fi +# if [ "${arch}" = "i386" ] || \ +# [ "${arch}" = "ppc64el" ] || \ +# [ "${arch}" = "s390x" ] || \ +# [ "${arch}" = "powerpc" ] ; then \ +# echo "Do not make tests on this architecture" ;\ +# else \ +# echo "Do make tests on this architecture" ;\ +# make -j4 check VERBOSE=1 ;\ +# fi endif diff -Nru libctl-4.4.0/doc/docs/index.md libctl-4.5.0/doc/docs/index.md --- libctl-4.4.0/doc/docs/index.md 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/doc/docs/index.md 2020-02-19 18:34:33.000000000 +0000 @@ -1,13 +1,13 @@ Welcome to the manual for **libctl**, a Guile-based library implementing flexible control files for scientific simulations. This documentation is divided into the following sections, which you should read roughly in order if you are new to libctl: -- [Introduction](/Introduction) — Motivation, history, and high-level structure of libctl. -- [Installation](/Installation) — Instructions for installing libctl on Unix-like systems such as Linux and macOS -- [Basic User Experience](/Basic_User_Experience) — Features of a basic **ctl** control file. -- [Advanced User Experience](/Advanced_User_Experience) — The ctl file is actually a Scheme program running in a full interpreter (called Guile) which enables a broad range of functionality. -- [User Reference](/libctl_User_Reference ) — Compact listing of the various functions provided for the user. -- [Developer Experience](/Developer_Experience) — By specifying an abstract **specification file** that describes the information that is exchanged with the ctl file, nearly everything else can be automated. -- [Guile and Scheme Information](/Guile_and_Scheme_links) — Guile is a standard GNU program for adding scripting and extensibility to software. It implements an embeddable interpreter for the Scheme language. There are many places that you can go to learn more about Guile and Scheme, and we link to a few of them here. -- [License and Copyright](/License_and_Copyright) — libctl is free and open-source software under the [GNU General Public License](http://www.gnu.org/copyleft/gpl.html) (GNU LGPL). +- [Introduction](Introduction.md) — Motivation, history, and high-level structure of libctl. +- [Installation](Installation.md) — Instructions for installing libctl on Unix-like systems such as Linux and macOS +- [Basic User Experience](Basic_User_Experience.md) — Features of a basic **ctl** control file. +- [Advanced User Experience](Advanced_User_Experience.md) — The ctl file is actually a Scheme program running in a full interpreter (called Guile) which enables a broad range of functionality. +- [User Reference](User_Reference.md) — Compact listing of the various functions provided for the user. +- [Developer Experience](Developer_Experience.md) — By specifying an abstract **specification file** that describes the information that is exchanged with the ctl file, nearly everything else can be automated. +- [Guile and Scheme Information](Guile_and_Scheme_Information.md) — Guile is a standard GNU program for adding scripting and extensibility to software. It implements an embeddable interpreter for the Scheme language. There are many places that you can go to learn more about Guile and Scheme, and we link to a few of them here. +- [License and Copyright](License_and_Copyright.md) — libctl is free and open-source software under the [GNU General Public License](http://www.gnu.org/copyleft/gpl.html) (GNU LGPL). Feedback -------- diff -Nru libctl-4.4.0/examples/example.c libctl-4.5.0/examples/example.c --- libctl-4.4.0/examples/example.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/examples/example.c 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -37,47 +37,37 @@ /* function to display a little information about a geometric object to prove that we've read it in correctly. */ -static void display_object_info(geometric_object obj) -{ - printf(" center = (%g,%g,%g), epsilon = %g\n", - obj.center.x, obj.center.y, - obj.center.z, obj.material.epsilon); +static void display_object_info(geometric_object obj) { + printf(" center = (%g,%g,%g), epsilon = %g\n", obj.center.x, obj.center.y, obj.center.z, + obj.material.epsilon); switch (obj.which_subclass) { - case CYLINDER: - printf(" cylinder with height %g, axis (%g, %g, %g)\n", - obj.subclass.cylinder_data->height, - obj.subclass.cylinder_data->axis.x, - obj.subclass.cylinder_data->axis.y, - obj.subclass.cylinder_data->axis.z); - break; - case SPHERE: - printf(" sphere with radius %g\n", - obj.subclass.sphere_data->radius); - break; - case BLOCK: - printf(" block with size (%g,%g,%g)\n", - obj.subclass.block_data->size.x, - obj.subclass.block_data->size.y, - obj.subclass.block_data->size.z); - printf(" projection matrix: %10.6f%10.6f%10.6f\n" - " %10.6f%10.6f%10.6f\n" - " %10.6f%10.6f%10.6f\n", - obj.subclass.block_data->projection_matrix.c0.x, - obj.subclass.block_data->projection_matrix.c1.x, - obj.subclass.block_data->projection_matrix.c2.x, - obj.subclass.block_data->projection_matrix.c0.y, - obj.subclass.block_data->projection_matrix.c1.y, - obj.subclass.block_data->projection_matrix.c2.y, - obj.subclass.block_data->projection_matrix.c0.z, - obj.subclass.block_data->projection_matrix.c1.z, - obj.subclass.block_data->projection_matrix.c2.z); - break; - case GEOMETRIC_OBJECT_SELF: - printf(" generic geometric object\n"); - break; - default: - printf(" UNKNOWN OBJECT TYPE!\n"); + case CYLINDER: + printf(" cylinder with height %g, axis (%g, %g, %g)\n", + obj.subclass.cylinder_data->height, obj.subclass.cylinder_data->axis.x, + obj.subclass.cylinder_data->axis.y, obj.subclass.cylinder_data->axis.z); + break; + case SPHERE: + printf(" sphere with radius %g\n", obj.subclass.sphere_data->radius); + break; + case BLOCK: + printf(" block with size (%g,%g,%g)\n", obj.subclass.block_data->size.x, + obj.subclass.block_data->size.y, obj.subclass.block_data->size.z); + printf(" projection matrix: %10.6f%10.6f%10.6f\n" + " %10.6f%10.6f%10.6f\n" + " %10.6f%10.6f%10.6f\n", + obj.subclass.block_data->projection_matrix.c0.x, + obj.subclass.block_data->projection_matrix.c1.x, + obj.subclass.block_data->projection_matrix.c2.x, + obj.subclass.block_data->projection_matrix.c0.y, + obj.subclass.block_data->projection_matrix.c1.y, + obj.subclass.block_data->projection_matrix.c2.y, + obj.subclass.block_data->projection_matrix.c0.z, + obj.subclass.block_data->projection_matrix.c1.z, + obj.subclass.block_data->projection_matrix.c2.z); + break; + case GEOMETRIC_OBJECT_SELF: printf(" generic geometric object\n"); break; + default: printf(" UNKNOWN OBJECT TYPE!\n"); } } @@ -85,8 +75,7 @@ is called, the input variables are already assigned. After it is called, the values assigned to the output variables are automatically exported to scheme. */ -void run_program(void) -{ +void run_program(void) { int i, depth, nobjects; vector3 p; geom_box_tree t; @@ -98,8 +87,7 @@ printf("\nk-points are:\n"); for (i = 0; i < k_points.num_items; ++i) - printf(" (%g,%g,%g)\n", - k_points.items[i].x, k_points.items[i].y, k_points.items[i].z); + printf(" (%g,%g,%g)\n", k_points.items[i].x, k_points.items[i].y, k_points.items[i].z); printf("\nsome geometry info:\n"); for (i = 0; i < geometry.num_items; ++i) @@ -109,14 +97,14 @@ printf("\ngeometry box tree:\n"); display_geom_box_tree(2, t); geom_box_tree_stats(t, &depth, &nobjects); - printf("\ntree has depth %d and %d object nodes (vs. %d objects)\n", - depth, nobjects, geometry.num_items); + printf("\ntree has depth %d and %d object nodes (vs. %d objects)\n", depth, nobjects, + geometry.num_items); - p.x = 1; p.y = 0; p.z = 0; - printf("Epsilon of (%g, %g) is %g (tree) or %g (non-tree)\n", - p.x, p.y, - material_of_point_in_tree(p, t).epsilon, - material_of_point(p).epsilon); + p.x = 1; + p.y = 0; + p.z = 0; + printf("Epsilon of (%g, %g) is %g (tree) or %g (non-tree)\n", p.x, p.y, + material_of_point_in_tree(p, t).epsilon, material_of_point(p).epsilon); destroy_geom_box_tree(t); @@ -126,16 +114,14 @@ MUST do this. If we leave any output variables uninitialized, the result is undefined. */ - if (num_write_output_vars > 1) - destroy_output_vars(); /* we are responsible for calling this */ + if (num_write_output_vars > 1) destroy_output_vars(); /* we are responsible for calling this */ - printf("dummy = (%g+%gi, %g+%gi, %g+%gi)\n", dummy.x.re, dummy.x.im, - dummy.y.re, dummy.y.im, dummy.z.re, dummy.z.im); - dummy = make_cvector3(vector3_scale(2, cvector3_re(dummy)), - vector3_scale(3, cvector3_im(dummy))); + printf("dummy = (%g+%gi, %g+%gi, %g+%gi)\n", dummy.x.re, dummy.x.im, dummy.y.re, dummy.y.im, + dummy.z.re, dummy.z.im); + dummy = make_cvector3(vector3_scale(2, cvector3_re(dummy)), vector3_scale(3, cvector3_im(dummy))); mean_dielectric = 1.23456789; gaps.num_items = 2; - gaps.items = (number *) malloc(gaps.num_items * sizeof(number)); + gaps.items = (number *)malloc(gaps.num_items * sizeof(number)); gaps.items[0] = 3.14159; gaps.items[1] = 1.41421; } @@ -147,8 +133,7 @@ In a real program, this might return the fraction of the field energy in the given object. */ -number energy_in_object(geometric_object obj) -{ +number energy_in_object(geometric_object obj) { printf("Computing power in object.\n"); display_object_info(obj); printf("Returning 0.123456.\n"); @@ -157,22 +142,18 @@ /* A function to test passing and returning list parameters to/from Scheme: */ -vector3_list list_func_test(number x, integer_list s, vector3 v) -{ - vector3_list vout; - int i; - - vout.num_items = s.num_items; - vout.items = (vector3*) malloc(sizeof(vector3) * vout.num_items); - for (i = 0; i < vout.num_items; ++i) - vout.items[i] = vector3_scale(s.items[i] * x, v); - return vout; +vector3_list list_func_test(number x, integer_list s, vector3 v) { + vector3_list vout; + int i; + + vout.num_items = s.num_items; + vout.items = (vector3 *)malloc(sizeof(vector3) * vout.num_items); + for (i = 0; i < vout.num_items; ++i) + vout.items[i] = vector3_scale(s.items[i] * x, v); + return vout; } /* return func(arg), where func is a Scheme function returning a number. */ -number function_func(function func, number arg) -{ - return - ctl_convert_number_to_c( - gh_call1(func, ctl_convert_number_to_scm(arg))); +number function_func(function func, number arg) { + return ctl_convert_number_to_c(gh_call1(func, ctl_convert_number_to_scm(arg))); } diff -Nru libctl-4.4.0/examples/example.scm.in libctl-4.5.0/examples/example.scm.in --- libctl-4.4.0/examples/example.scm.in 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/examples/example.scm.in 2020-02-19 18:34:33.000000000 +0000 @@ -1,4 +1,4 @@ -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This file may be used without restriction. It is in the public ; domain, and is NOT restricted by the terms of any GNU license. diff -Nru libctl-4.4.0/examples/run.ctl libctl-4.5.0/examples/run.ctl --- libctl-4.4.0/examples/run.ctl 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/examples/run.ctl 2020-02-19 18:34:33.000000000 +0000 @@ -1,4 +1,4 @@ -; Copyright (C) 1998-2019 Steven G. Johnson +; Copyright (C) 1998-2020 Steven G. Johnson ; ; This file may be used without restriction. It is in the public ; domain, and is NOT restricted by the terms of any GNU license. diff -Nru libctl-4.4.0/.gitignore libctl-4.5.0/.gitignore --- libctl-4.4.0/.gitignore 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/.gitignore 2020-02-19 18:34:33.000000000 +0000 @@ -53,3 +53,4 @@ geomtst nlopt-constants.scm utils/test-prism +*.dat \ No newline at end of file diff -Nru libctl-4.4.0/NEWS.md libctl-4.5.0/NEWS.md --- libctl-4.4.0/NEWS.md 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/NEWS.md 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,17 @@ # Libctl Release Notes +## libctl 4.5.0 + +2/19/20 + +* New `make_slanted_prism` functions to make a prism with + a given sidewall angle (#53). + +* Defined `LIBCTL_MAJOR_VERSION` etc. in `ctlgeom.h` header file when + using stand-alone libctlgeom. + +* Bugfix in point-in-prism test (#49). + ## libctl 4.4.0 11/12/19 diff -Nru libctl-4.4.0/src/cintegrator.c libctl-4.5.0/src/cintegrator.c --- libctl-4.4.0/src/cintegrator.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/src/cintegrator.c 2020-02-19 18:34:33.000000000 +0000 @@ -62,7 +62,7 @@ typedef complex double num; #define num_abs cabs -typedef num (*integrand) (unsigned ndim, const double *x, void *); +typedef num (*integrand)(unsigned ndim, const double *x, void *); /* Integrate the function f from xmin[dim] to xmax[dim], with at most maxEval function evaluations (0 for no limit), until the given @@ -70,120 +70,103 @@ and err returns the estimate for the absolute error in val. The return value of the function is 0 on success and non-zero if there was an error. */ -static int adapt_integrate(integrand f, void *fdata, - unsigned dim, const double *xmin, const double *xmax, - unsigned maxEval, - double reqAbsError, double reqRelError, - num *val, double *err); +static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, + const double *xmax, unsigned maxEval, double reqAbsError, + double reqRelError, num *val, double *err); /***************************************************************************/ /* Basic datatypes */ typedef struct { - num val; - double err; + num val; + double err; } esterr; -static double relError(esterr ee) -{ - return (ee.val == 0.0 ? HUGE_VAL : num_abs(ee.err / ee.val)); -} +static double relError(esterr ee) { return (ee.val == 0.0 ? HUGE_VAL : num_abs(ee.err / ee.val)); } typedef struct { - unsigned dim; - double *data; /* length 2*dim = center followed by half-widths */ - double vol; /* cache volume = product of widths */ + unsigned dim; + double *data; /* length 2*dim = center followed by half-widths */ + double vol; /* cache volume = product of widths */ } hypercube; -static double compute_vol(const hypercube *h) -{ - unsigned i; - double vol = 1; - for (i = 0; i < h->dim; ++i) - vol *= 2 * h->data[i + h->dim]; - return vol; -} - -static hypercube make_hypercube(unsigned dim, const double *center, const double *halfwidth) -{ - unsigned i; - hypercube h; - h.dim = dim; - h.data = (double *) malloc(sizeof(double) * dim * 2); - for (i = 0; i < dim; ++i) { - h.data[i] = center[i]; - h.data[i + dim] = halfwidth[i]; - } - h.vol = compute_vol(&h); - return h; -} - -static hypercube make_hypercube_range(unsigned dim, const double *xmin, const double *xmax) -{ - hypercube h = make_hypercube(dim, xmin, xmax); - unsigned i; - for (i = 0; i < dim; ++i) { - h.data[i] = 0.5 * (xmin[i] + xmax[i]); - h.data[i + dim] = 0.5 * (xmax[i] - xmin[i]); - } - h.vol = compute_vol(&h); - return h; -} - -static void destroy_hypercube(hypercube *h) -{ - free(h->data); - h->dim = 0; +static double compute_vol(const hypercube *h) { + unsigned i; + double vol = 1; + for (i = 0; i < h->dim; ++i) + vol *= 2 * h->data[i + h->dim]; + return vol; +} + +static hypercube make_hypercube(unsigned dim, const double *center, const double *halfwidth) { + unsigned i; + hypercube h; + h.dim = dim; + h.data = (double *)malloc(sizeof(double) * dim * 2); + for (i = 0; i < dim; ++i) { + h.data[i] = center[i]; + h.data[i + dim] = halfwidth[i]; + } + h.vol = compute_vol(&h); + return h; +} + +static hypercube make_hypercube_range(unsigned dim, const double *xmin, const double *xmax) { + hypercube h = make_hypercube(dim, xmin, xmax); + unsigned i; + for (i = 0; i < dim; ++i) { + h.data[i] = 0.5 * (xmin[i] + xmax[i]); + h.data[i + dim] = 0.5 * (xmax[i] - xmin[i]); + } + h.vol = compute_vol(&h); + return h; +} + +static void destroy_hypercube(hypercube *h) { + free(h->data); + h->dim = 0; } typedef struct { - hypercube h; - esterr ee; - unsigned splitDim; + hypercube h; + esterr ee; + unsigned splitDim; } region; -static region make_region(const hypercube *h) -{ - region R; - R.h = make_hypercube(h->dim, h->data, h->data + h->dim); - R.splitDim = 0; - return R; -} - -static void destroy_region(region *R) -{ - destroy_hypercube(&R->h); -} - -static void cut_region(region *R, region *R2) -{ - unsigned d = R->splitDim, dim = R->h.dim; - *R2 = *R; - R->h.data[d + dim] *= 0.5; - R->h.vol *= 0.5; - R2->h = make_hypercube(dim, R->h.data, R->h.data + dim); - R->h.data[d] -= R->h.data[d + dim]; - R2->h.data[d] += R->h.data[d + dim]; +static region make_region(const hypercube *h) { + region R; + R.h = make_hypercube(h->dim, h->data, h->data + h->dim); + R.splitDim = 0; + return R; +} + +static void destroy_region(region *R) { destroy_hypercube(&R->h); } + +static void cut_region(region *R, region *R2) { + unsigned d = R->splitDim, dim = R->h.dim; + *R2 = *R; + R->h.data[d + dim] *= 0.5; + R->h.vol *= 0.5; + R2->h = make_hypercube(dim, R->h.data, R->h.data + dim); + R->h.data[d] -= R->h.data[d + dim]; + R2->h.data[d] += R->h.data[d + dim]; } typedef struct rule_s { - unsigned dim; /* the dimensionality */ - unsigned num_points; /* number of evaluation points */ - unsigned (*evalError)(struct rule_s *r, integrand f, void *fdata, - const hypercube *h, esterr *ee); - void (*destroy)(struct rule_s *r); + unsigned dim; /* the dimensionality */ + unsigned num_points; /* number of evaluation points */ + unsigned (*evalError)(struct rule_s *r, integrand f, void *fdata, const hypercube *h, esterr *ee); + void (*destroy)(struct rule_s *r); } rule; -static void destroy_rule(rule *r) -{ - if (r->destroy) r->destroy(r); - free(r); +static void destroy_rule(rule *r) { + if (r->destroy) r->destroy(r); + free(r); } -static region eval_region(region R, integrand f, void *fdata, rule *r) -{ - R.splitDim = r->evalError(r, f, fdata, &R.h, &R.ee); - return R; +static region eval_region(region R, integrand f, void *fdata, rule *r) { + R.splitDim = r->evalError(r, f, fdata, &R.h, &R.ee); + return R; } /***************************************************************************/ @@ -194,43 +177,34 @@ /* ls0 returns the least-significant 0 bit of n (e.g. it returns 0 if the LSB is 0, it returns 1 if the 2 LSBs are 01, etcetera). */ -#if (defined(__GNUC__) || defined(__ICC)) && (defined(__i386__) || defined (__x86_64__)) +#if (defined(__GNUC__) || defined(__ICC)) && (defined(__i386__) || defined(__x86_64__)) /* use x86 bit-scan instruction, based on count_trailing_zeros() macro in GNU GMP's longlong.h. */ -static unsigned ls0(unsigned n) -{ - unsigned count; - n = ~n; - __asm__("bsfl %1,%0": "=r"(count):"rm"(n)); - return count; +static unsigned ls0(unsigned n) { + unsigned count; + n = ~n; + __asm__("bsfl %1,%0" : "=r"(count) : "rm"(n)); + return count; } #else -static unsigned ls0(unsigned n) -{ - const unsigned bits[256] = { - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 8, - }; - unsigned bit = 0; - while ((n & 0xff) == 0xff) { - n >>= 8; - bit += 8; - } - return bit + bits[n & 0xff]; +static unsigned ls0(unsigned n) { + const unsigned bits[256] = { + 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, + 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, + 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, + 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, + 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, + 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, + 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, + 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, + 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 8, + }; + unsigned bit = 0; + while ((n & 0xff) == 0xff) { + n >>= 8; + bit += 8; + } + return bit + bits[n & 0xff]; } #endif @@ -240,102 +214,102 @@ * A Gray-code ordering is used to minimize the number of coordinate updates * in p. */ -static num evalR_Rfs(integrand f, void *fdata, unsigned dim, double *p, const double *c, const double *r) -{ - num sum = 0; - unsigned i; - unsigned signs = 0; /* 0/1 bit = +/- for corresponding element of r[] */ - - /* We start with the point where r is ADDed in every coordinate - (this implies signs=0). */ - for (i = 0; i < dim; ++i) - p[i] = c[i] + r[i]; - - /* Loop through the points in Gray-code ordering */ - for (i = 0;; ++i) { - unsigned mask, d; - - sum += f(dim, p, fdata); - - d = ls0(i); /* which coordinate to flip */ - if (d >= dim) - break; - - /* flip the d-th bit and add/subtract r[d] */ - mask = 1U << d; - signs ^= mask; - p[d] = (signs & mask) ? c[d] - r[d] : c[d] + r[d]; - } - return sum; -} - -static num evalRR0_0fs(integrand f, void *fdata, unsigned dim, double *p, const double *c, const double *r) -{ - unsigned i, j; - num sum = 0; - - for (i = 0; i < dim - 1; ++i) { - p[i] = c[i] - r[i]; - for (j = i + 1; j < dim; ++j) { - p[j] = c[j] - r[j]; - sum += f(dim, p, fdata); - p[i] = c[i] + r[i]; - sum += f(dim, p, fdata); - p[j] = c[j] + r[j]; - sum += f(dim, p, fdata); - p[i] = c[i] - r[i]; - sum += f(dim, p, fdata); - - p[j] = c[j]; /* Done with j -> Restore p[j] */ - } - p[i] = c[i]; /* Done with i -> Restore p[i] */ - } - return sum; -} - -static unsigned evalR0_0fs4d(integrand f, void *fdata, unsigned dim, double *p, const double *c, num *sum0_, const double *r1, num *sum1_, const double *r2, num *sum2_) -{ - double maxdiff = 0; - unsigned i, dimDiffMax = 0; - num sum0, sum1 = 0, sum2 = 0; /* copies for aliasing, performance */ - - double ratio = r1[0] / r2[0]; - - ratio *= ratio; - sum0 = f(dim, p, fdata); - - for (i = 0; i < dim; i++) { - num f1a, f1b, f2a, f2b; - double diff; - - p[i] = c[i] - r1[i]; - sum1 += (f1a = f(dim, p, fdata)); - p[i] = c[i] + r1[i]; - sum1 += (f1b = f(dim, p, fdata)); - p[i] = c[i] - r2[i]; - sum2 += (f2a = f(dim, p, fdata)); - p[i] = c[i] + r2[i]; - sum2 += (f2b = f(dim, p, fdata)); - p[i] = c[i]; - - diff = num_abs(f1a + f1b - 2 * sum0 - ratio * (f2a + f2b - 2 * sum0)); - - if (diff > maxdiff) { - maxdiff = diff; - dimDiffMax = i; - } - } - - *sum0_ += sum0; - *sum1_ += sum1; - *sum2_ += sum2; +static num evalR_Rfs(integrand f, void *fdata, unsigned dim, double *p, const double *c, + const double *r) { + num sum = 0; + unsigned i; + unsigned signs = 0; /* 0/1 bit = +/- for corresponding element of r[] */ + + /* We start with the point where r is ADDed in every coordinate + (this implies signs=0). */ + for (i = 0; i < dim; ++i) + p[i] = c[i] + r[i]; + + /* Loop through the points in Gray-code ordering */ + for (i = 0;; ++i) { + unsigned mask, d; + + sum += f(dim, p, fdata); + + d = ls0(i); /* which coordinate to flip */ + if (d >= dim) break; + + /* flip the d-th bit and add/subtract r[d] */ + mask = 1U << d; + signs ^= mask; + p[d] = (signs & mask) ? c[d] - r[d] : c[d] + r[d]; + } + return sum; +} + +static num evalRR0_0fs(integrand f, void *fdata, unsigned dim, double *p, const double *c, + const double *r) { + unsigned i, j; + num sum = 0; + + for (i = 0; i < dim - 1; ++i) { + p[i] = c[i] - r[i]; + for (j = i + 1; j < dim; ++j) { + p[j] = c[j] - r[j]; + sum += f(dim, p, fdata); + p[i] = c[i] + r[i]; + sum += f(dim, p, fdata); + p[j] = c[j] + r[j]; + sum += f(dim, p, fdata); + p[i] = c[i] - r[i]; + sum += f(dim, p, fdata); + + p[j] = c[j]; /* Done with j -> Restore p[j] */ + } + p[i] = c[i]; /* Done with i -> Restore p[i] */ + } + return sum; +} + +static unsigned evalR0_0fs4d(integrand f, void *fdata, unsigned dim, double *p, const double *c, + num *sum0_, const double *r1, num *sum1_, const double *r2, + num *sum2_) { + double maxdiff = 0; + unsigned i, dimDiffMax = 0; + num sum0, sum1 = 0, sum2 = 0; /* copies for aliasing, performance */ + + double ratio = r1[0] / r2[0]; + + ratio *= ratio; + sum0 = f(dim, p, fdata); + + for (i = 0; i < dim; i++) { + num f1a, f1b, f2a, f2b; + double diff; + + p[i] = c[i] - r1[i]; + sum1 += (f1a = f(dim, p, fdata)); + p[i] = c[i] + r1[i]; + sum1 += (f1b = f(dim, p, fdata)); + p[i] = c[i] - r2[i]; + sum2 += (f2a = f(dim, p, fdata)); + p[i] = c[i] + r2[i]; + sum2 += (f2b = f(dim, p, fdata)); + p[i] = c[i]; + + diff = num_abs(f1a + f1b - 2 * sum0 - ratio * (f2a + f2b - 2 * sum0)); + + if (diff > maxdiff) { + maxdiff = diff; + dimDiffMax = i; + } + } + + *sum0_ += sum0; + *sum1_ += sum1; + *sum2_ += sum2; - return dimDiffMax; + return dimDiffMax; } #define num0_0(dim) (1U) #define numR0_0fs(dim) (2 * (dim)) -#define numRR0_0fs(dim) (2 * (dim) * (dim-1)) +#define numRR0_0fs(dim) (2 * (dim) * (dim - 1)) #define numR_Rfs(dim) (1U << (dim)) /***************************************************************************/ @@ -349,225 +323,215 @@ */ typedef struct { - rule parent; + rule parent; - /* temporary arrays of length dim */ - double *widthLambda, *widthLambda2, *p; + /* temporary arrays of length dim */ + double *widthLambda, *widthLambda2, *p; - /* dimension-dependent constants */ - double weight1, weight3, weight5; - double weightE1, weightE3; + /* dimension-dependent constants */ + double weight1, weight3, weight5; + double weightE1, weightE3; } rule75genzmalik; #define real(x) ((double)(x)) #define to_int(n) ((int)(n)) -static int isqr(int x) -{ - return x * x; -} +static int isqr(int x) { return x * x; } -static void destroy_rule75genzmalik(rule *r_) -{ - rule75genzmalik *r = (rule75genzmalik *) r_; - free(r->p); +static void destroy_rule75genzmalik(rule *r_) { + rule75genzmalik *r = (rule75genzmalik *)r_; + free(r->p); } -static unsigned rule75genzmalik_evalError(rule *r_, integrand f, void *fdata, const hypercube *h, esterr *ee) -{ - /* lambda2 = sqrt(9/70), lambda4 = sqrt(9/10), lambda5 = sqrt(9/19) */ - const double lambda2 = 0.3585685828003180919906451539079374954541; - const double lambda4 = 0.9486832980505137995996680633298155601160; - const double lambda5 = 0.6882472016116852977216287342936235251269; - const double weight2 = 980. / 6561.; - const double weight4 = 200. / 19683.; - const double weightE2 = 245. / 486.; - const double weightE4 = 25. / 729.; +static unsigned rule75genzmalik_evalError(rule *r_, integrand f, void *fdata, const hypercube *h, + esterr *ee) { + /* lambda2 = sqrt(9/70), lambda4 = sqrt(9/10), lambda5 = sqrt(9/19) */ + const double lambda2 = 0.3585685828003180919906451539079374954541; + const double lambda4 = 0.9486832980505137995996680633298155601160; + const double lambda5 = 0.6882472016116852977216287342936235251269; + const double weight2 = 980. / 6561.; + const double weight4 = 200. / 19683.; + const double weightE2 = 245. / 486.; + const double weightE4 = 25. / 729.; - rule75genzmalik *r = (rule75genzmalik *) r_; - unsigned i, dimDiffMax, dim = r_->dim; - num sum1 = 0.0, sum2 = 0.0, sum3 = 0.0, sum4, sum5, result, res5th; - const double *center = h->data; - const double *halfwidth = h->data + dim; + rule75genzmalik *r = (rule75genzmalik *)r_; + unsigned i, dimDiffMax, dim = r_->dim; + num sum1 = 0.0, sum2 = 0.0, sum3 = 0.0, sum4, sum5, result, res5th; + const double *center = h->data; + const double *halfwidth = h->data + dim; - for (i = 0; i < dim; ++i) - r->p[i] = center[i]; + for (i = 0; i < dim; ++i) + r->p[i] = center[i]; - for (i = 0; i < dim; ++i) - r->widthLambda2[i] = halfwidth[i] * lambda2; - for (i = 0; i < dim; ++i) - r->widthLambda[i] = halfwidth[i] * lambda4; + for (i = 0; i < dim; ++i) + r->widthLambda2[i] = halfwidth[i] * lambda2; + for (i = 0; i < dim; ++i) + r->widthLambda[i] = halfwidth[i] * lambda4; - /* Evaluate function in the center, in f(lambda2,0,...,0) and - f(lambda3=lambda4, 0,...,0). Estimate dimension with largest error */ - dimDiffMax = evalR0_0fs4d(f, fdata, dim, r->p, center, &sum1, r->widthLambda2, &sum2, r->widthLambda, &sum3); + /* Evaluate function in the center, in f(lambda2,0,...,0) and + f(lambda3=lambda4, 0,...,0). Estimate dimension with largest error */ + dimDiffMax = evalR0_0fs4d(f, fdata, dim, r->p, center, &sum1, r->widthLambda2, &sum2, + r->widthLambda, &sum3); - /* Calculate sum4 for f(lambda4, lambda4, 0, ...,0) */ - sum4 = evalRR0_0fs(f, fdata, dim, r->p, center, r->widthLambda); + /* Calculate sum4 for f(lambda4, lambda4, 0, ...,0) */ + sum4 = evalRR0_0fs(f, fdata, dim, r->p, center, r->widthLambda); - /* Calculate sum5 for f(lambda5, lambda5, ..., lambda5) */ - for (i = 0; i < dim; ++i) - r->widthLambda[i] = halfwidth[i] * lambda5; - sum5 = evalR_Rfs(f, fdata, dim, r->p, center, r->widthLambda); + /* Calculate sum5 for f(lambda5, lambda5, ..., lambda5) */ + for (i = 0; i < dim; ++i) + r->widthLambda[i] = halfwidth[i] * lambda5; + sum5 = evalR_Rfs(f, fdata, dim, r->p, center, r->widthLambda); - /* Calculate fifth and seventh order results */ + /* Calculate fifth and seventh order results */ - result = h->vol * (r->weight1 * sum1 + weight2 * sum2 + r->weight3 * sum3 + weight4 * sum4 + r->weight5 * sum5); - res5th = h->vol * (r->weightE1 * sum1 + weightE2 * sum2 + r->weightE3 * sum3 + weightE4 * sum4); + result = h->vol * (r->weight1 * sum1 + weight2 * sum2 + r->weight3 * sum3 + weight4 * sum4 + + r->weight5 * sum5); + res5th = h->vol * (r->weightE1 * sum1 + weightE2 * sum2 + r->weightE3 * sum3 + weightE4 * sum4); - ee->val = result; - ee->err = num_abs(res5th - result); + ee->val = result; + ee->err = num_abs(res5th - result); - return dimDiffMax; + return dimDiffMax; } -static rule *make_rule75genzmalik(unsigned dim) -{ - rule75genzmalik *r; +static rule *make_rule75genzmalik(unsigned dim) { + rule75genzmalik *r; - if (dim < 2) return 0; /* this rule does not support 1d integrals */ + if (dim < 2) return 0; /* this rule does not support 1d integrals */ - /* Because of the use of a bit-field in evalR_Rfs, we are limited - to be < 32 dimensions (or however many bits are in unsigned). - This is not a practical limitation...long before you reach - 32 dimensions, the Genz-Malik cubature becomes excruciatingly - slow and is superseded by other methods (e.g. Monte-Carlo). */ - if (dim >= sizeof(unsigned) * 8) return 0; + /* Because of the use of a bit-field in evalR_Rfs, we are limited + to be < 32 dimensions (or however many bits are in unsigned). + This is not a practical limitation...long before you reach + 32 dimensions, the Genz-Malik cubature becomes excruciatingly + slow and is superseded by other methods (e.g. Monte-Carlo). */ + if (dim >= sizeof(unsigned) * 8) return 0; - r = (rule75genzmalik *) malloc(sizeof(rule75genzmalik)); - r->parent.dim = dim; + r = (rule75genzmalik *)malloc(sizeof(rule75genzmalik)); + r->parent.dim = dim; - r->weight1 = (real(12824 - 9120 * to_int(dim) + 400 * isqr(to_int(dim))) - / real(19683)); - r->weight3 = real(1820 - 400 * to_int(dim)) / real(19683); - r->weight5 = real(6859) / real(19683) / real(1U << dim); - r->weightE1 = (real(729 - 950 * to_int(dim) + 50 * isqr(to_int(dim))) - / real(729)); - r->weightE3 = real(265 - 100 * to_int(dim)) / real(1458); + r->weight1 = (real(12824 - 9120 * to_int(dim) + 400 * isqr(to_int(dim))) / real(19683)); + r->weight3 = real(1820 - 400 * to_int(dim)) / real(19683); + r->weight5 = real(6859) / real(19683) / real(1U << dim); + r->weightE1 = (real(729 - 950 * to_int(dim) + 50 * isqr(to_int(dim))) / real(729)); + r->weightE3 = real(265 - 100 * to_int(dim)) / real(1458); - r->p = (double *) malloc(sizeof(double) * dim * 3); - r->widthLambda = r->p + dim; - r->widthLambda2 = r->p + 2 * dim; + r->p = (double *)malloc(sizeof(double) * dim * 3); + r->widthLambda = r->p + dim; + r->widthLambda2 = r->p + 2 * dim; - r->parent.num_points = num0_0(dim) + 2 * numR0_0fs(dim) - + numRR0_0fs(dim) + numR_Rfs(dim); + r->parent.num_points = num0_0(dim) + 2 * numR0_0fs(dim) + numRR0_0fs(dim) + numR_Rfs(dim); - r->parent.evalError = rule75genzmalik_evalError; - r->parent.destroy = destroy_rule75genzmalik; + r->parent.evalError = rule75genzmalik_evalError; + r->parent.destroy = destroy_rule75genzmalik; - return (rule *) r; + return (rule *)r; } /***************************************************************************/ /* 1d 15-point Gaussian quadrature rule, based on qk15.c and qk.c in GNU GSL (which in turn is based on QUADPACK). */ -static unsigned rule15gauss_evalError(rule *r, integrand f, void *fdata, - const hypercube *h, esterr *ee) -{ - /* Gauss quadrature weights and kronrod quadrature abscissae and - weights as evaluated with 80 decimal digit arithmetic by - L. W. Fullerton, Bell Labs, Nov. 1981. */ - const unsigned n = 8; - const double xgk[8] = { /* abscissae of the 15-point kronrod rule */ - 0.991455371120812639206854697526329, - 0.949107912342758524526189684047851, - 0.864864423359769072789712788640926, - 0.741531185599394439863864773280788, - 0.586087235467691130294144838258730, - 0.405845151377397166906606412076961, - 0.207784955007898467600689403773245, - 0.000000000000000000000000000000000 - /* xgk[1], xgk[3], ... abscissae of the 7-point gauss rule. - xgk[0], xgk[2], ... to optimally extend the 7-point gauss rule */ - }; - static const double wg[4] = { /* weights of the 7-point gauss rule */ - 0.129484966168869693270611432679082, - 0.279705391489276667901467771423780, - 0.381830050505118944950369775488975, - 0.417959183673469387755102040816327 - }; - static const double wgk[8] = { /* weights of the 15-point kronrod rule */ - 0.022935322010529224963732008058970, - 0.063092092629978553290700663189204, - 0.104790010322250183839876322541518, - 0.140653259715525918745189590510238, - 0.169004726639267902826583426598550, - 0.190350578064785409913256402421014, - 0.204432940075298892414161999234649, - 0.209482141084727828012999174891714 - }; - - const double center = h->data[0]; - const double halfwidth = h->data[1]; - double fv1[7], fv2[7]; - const num f_center = f(1, ¢er, fdata); - num result_gauss = f_center * wg[n/2 - 1]; - num result_kronrod = f_center * wgk[n - 1]; - double result_abs = num_abs(result_kronrod); - num mean; - double result_asc, err; - unsigned j; - - for (j = 0; j < (n - 1) / 2; ++j) { - int j2 = 2*j + 1; - double x, w = halfwidth * xgk[j2]; - num f1, f2, fsum; - x = center - w; fv1[j2] = f1 = f(1, &x, fdata); - x = center + w; fv2[j2] = f2 = f(1, &x, fdata); - fsum = f1 + f2; - result_gauss += wg[j] * fsum; - result_kronrod += wgk[j2] * fsum; - result_abs += wgk[j2] * (num_abs(f1) + num_abs(f2)); - } - - for (j = 0; j < n/2; ++j) { - int j2 = 2*j; - double x, w = halfwidth * xgk[j2]; - num f1, f2; - x = center - w; fv1[j2] = f1 = f(1, &x, fdata); - x = center + w; fv2[j2] = f2 = f(1, &x, fdata); - result_kronrod += wgk[j2] * (f1 + f2); - result_abs += wgk[j2] * (num_abs(f1) + num_abs(f2)); - } - - ee->val = result_kronrod * halfwidth; - - /* compute error estimate: */ - mean = result_kronrod * 0.5; - result_asc = wgk[n - 1] * num_abs(f_center - mean); - for (j = 0; j < n - 1; ++j) - result_asc += wgk[j] * (num_abs(fv1[j]-mean) + num_abs(fv2[j]-mean)); - err = num_abs(result_kronrod - result_gauss) * halfwidth; - result_abs *= halfwidth; - result_asc *= halfwidth; - if (result_asc != 0 && err != 0) { - double scale = pow((200 * err / result_asc), 1.5); - if (scale < 1) - err = result_asc * scale; - else - err = result_asc; - } - if (result_abs > DBL_MIN / (50 * DBL_EPSILON)) { - double min_err = 50 * DBL_EPSILON * result_abs; - if (min_err > err) - err = min_err; - } - ee->err = err; - - return 0; /* no choice but to divide 0th dimension */ -} - -static rule *make_rule15gauss(unsigned dim) -{ - rule *r; - if (dim != 1) return 0; /* this rule is only for 1d integrals */ - r = (rule *) malloc(sizeof(rule)); - r->dim = dim; - r->num_points = 15; - r->evalError = rule15gauss_evalError; - r->destroy = 0; - return r; +static unsigned rule15gauss_evalError(rule *r, integrand f, void *fdata, const hypercube *h, + esterr *ee) { + /* Gauss quadrature weights and kronrod quadrature abscissae and + weights as evaluated with 80 decimal digit arithmetic by + L. W. Fullerton, Bell Labs, Nov. 1981. */ + const unsigned n = 8; + const double xgk[8] = { + /* abscissae of the 15-point kronrod rule */ + 0.991455371120812639206854697526329, + 0.949107912342758524526189684047851, + 0.864864423359769072789712788640926, + 0.741531185599394439863864773280788, + 0.586087235467691130294144838258730, + 0.405845151377397166906606412076961, + 0.207784955007898467600689403773245, + 0.000000000000000000000000000000000 + /* xgk[1], xgk[3], ... abscissae of the 7-point gauss rule. + xgk[0], xgk[2], ... to optimally extend the 7-point gauss rule */ + }; + static const double wg[4] = { + /* weights of the 7-point gauss rule */ + 0.129484966168869693270611432679082, 0.279705391489276667901467771423780, + 0.381830050505118944950369775488975, 0.417959183673469387755102040816327}; + static const double wgk[8] = { + /* weights of the 15-point kronrod rule */ + 0.022935322010529224963732008058970, 0.063092092629978553290700663189204, + 0.104790010322250183839876322541518, 0.140653259715525918745189590510238, + 0.169004726639267902826583426598550, 0.190350578064785409913256402421014, + 0.204432940075298892414161999234649, 0.209482141084727828012999174891714}; + + const double center = h->data[0]; + const double halfwidth = h->data[1]; + double fv1[7], fv2[7]; + const num f_center = f(1, ¢er, fdata); + num result_gauss = f_center * wg[n / 2 - 1]; + num result_kronrod = f_center * wgk[n - 1]; + double result_abs = num_abs(result_kronrod); + num mean; + double result_asc, err; + unsigned j; + + for (j = 0; j < (n - 1) / 2; ++j) { + int j2 = 2 * j + 1; + double x, w = halfwidth * xgk[j2]; + num f1, f2, fsum; + x = center - w; + fv1[j2] = f1 = f(1, &x, fdata); + x = center + w; + fv2[j2] = f2 = f(1, &x, fdata); + fsum = f1 + f2; + result_gauss += wg[j] * fsum; + result_kronrod += wgk[j2] * fsum; + result_abs += wgk[j2] * (num_abs(f1) + num_abs(f2)); + } + + for (j = 0; j < n / 2; ++j) { + int j2 = 2 * j; + double x, w = halfwidth * xgk[j2]; + num f1, f2; + x = center - w; + fv1[j2] = f1 = f(1, &x, fdata); + x = center + w; + fv2[j2] = f2 = f(1, &x, fdata); + result_kronrod += wgk[j2] * (f1 + f2); + result_abs += wgk[j2] * (num_abs(f1) + num_abs(f2)); + } + + ee->val = result_kronrod * halfwidth; + + /* compute error estimate: */ + mean = result_kronrod * 0.5; + result_asc = wgk[n - 1] * num_abs(f_center - mean); + for (j = 0; j < n - 1; ++j) + result_asc += wgk[j] * (num_abs(fv1[j] - mean) + num_abs(fv2[j] - mean)); + err = num_abs(result_kronrod - result_gauss) * halfwidth; + result_abs *= halfwidth; + result_asc *= halfwidth; + if (result_asc != 0 && err != 0) { + double scale = pow((200 * err / result_asc), 1.5); + if (scale < 1) + err = result_asc * scale; + else + err = result_asc; + } + if (result_abs > DBL_MIN / (50 * DBL_EPSILON)) { + double min_err = 50 * DBL_EPSILON * result_abs; + if (min_err > err) err = min_err; + } + ee->err = err; + + return 0; /* no choice but to divide 0th dimension */ +} + +static rule *make_rule15gauss(unsigned dim) { + rule *r; + if (dim != 1) return 0; /* this rule is only for 1d integrals */ + r = (rule *)malloc(sizeof(rule)); + r->dim = dim; + r->num_points = 15; + r->evalError = rule15gauss_evalError; + r->destroy = 0; + return r; } /***************************************************************************/ @@ -579,166 +543,156 @@ #define KEY(hi) ((hi).ee.err) typedef struct { - unsigned n, nalloc; - heap_item *items; - esterr ee; + unsigned n, nalloc; + heap_item *items; + esterr ee; } heap; -static void heap_resize(heap *h, unsigned nalloc) -{ - h->nalloc = nalloc; - h->items = (heap_item *) realloc(h->items, sizeof(heap_item) * nalloc); +static void heap_resize(heap *h, unsigned nalloc) { + h->nalloc = nalloc; + h->items = (heap_item *)realloc(h->items, sizeof(heap_item) * nalloc); } -static heap heap_alloc(unsigned nalloc) -{ - heap h; - h.n = 0; - h.nalloc = 0; - h.items = 0; - h.ee.val = h.ee.err = 0; - heap_resize(&h, nalloc); - return h; +static heap heap_alloc(unsigned nalloc) { + heap h; + h.n = 0; + h.nalloc = 0; + h.items = 0; + h.ee.val = h.ee.err = 0; + heap_resize(&h, nalloc); + return h; } /* note that heap_free does not deallocate anything referenced by the items */ -static void heap_free(heap *h) -{ - h->n = 0; - heap_resize(h, 0); -} - -static void heap_push(heap *h, heap_item hi) -{ - int insert; - - h->ee.val += hi.ee.val; - h->ee.err += hi.ee.err; - insert = h->n; - if (++(h->n) > h->nalloc) - heap_resize(h, h->n * 2); - - while (insert) { - int parent = (insert - 1) / 2; - if (KEY(hi) <= KEY(h->items[parent])) - break; - h->items[insert] = h->items[parent]; - insert = parent; - } - h->items[insert] = hi; -} - -static heap_item heap_pop(heap *h) -{ - heap_item ret; - int i, n, child; - - if (!(h->n)) { - fprintf(stderr, "attempted to pop an empty heap\n"); - exit(EXIT_FAILURE); - } - - ret = h->items[0]; - h->items[i = 0] = h->items[n = --(h->n)]; - while ((child = i * 2 + 1) < n) { - int largest; - heap_item swap; - - if (KEY(h->items[child]) <= KEY(h->items[i])) - largest = i; - else - largest = child; - if (++child < n && KEY(h->items[largest]) < KEY(h->items[child])) - largest = child; - if (largest == i) - break; - swap = h->items[i]; - h->items[i] = h->items[largest]; - h->items[i = largest] = swap; - } - - h->ee.val -= ret.ee.val; - h->ee.err -= ret.ee.err; - return ret; +static void heap_free(heap *h) { + h->n = 0; + heap_resize(h, 0); +} + +static void heap_push(heap *h, heap_item hi) { + int insert; + + h->ee.val += hi.ee.val; + h->ee.err += hi.ee.err; + insert = h->n; + if (++(h->n) > h->nalloc) heap_resize(h, h->n * 2); + + while (insert) { + int parent = (insert - 1) / 2; + if (KEY(hi) <= KEY(h->items[parent])) break; + h->items[insert] = h->items[parent]; + insert = parent; + } + h->items[insert] = hi; +} + +static heap_item heap_pop(heap *h) { + heap_item ret; + int i, n, child; + + if (!(h->n)) { + fprintf(stderr, "attempted to pop an empty heap\n"); + exit(EXIT_FAILURE); + } + + ret = h->items[0]; + h->items[i = 0] = h->items[n = --(h->n)]; + while ((child = i * 2 + 1) < n) { + int largest; + heap_item swap; + + if (KEY(h->items[child]) <= KEY(h->items[i])) + largest = i; + else + largest = child; + if (++child < n && KEY(h->items[largest]) < KEY(h->items[child])) largest = child; + if (largest == i) break; + swap = h->items[i]; + h->items[i] = h->items[largest]; + h->items[i = largest] = swap; + } + + h->ee.val -= ret.ee.val; + h->ee.err -= ret.ee.err; + return ret; } /***************************************************************************/ /* adaptive integration, analogous to adaptintegrator.cpp in HIntLib */ -static int ruleadapt_integrate(rule *r, integrand f, void *fdata, const hypercube *h, unsigned maxEval, double reqAbsError, double reqRelError, esterr *ee) -{ - unsigned maxIter; /* maximum number of adaptive subdivisions */ - heap regions; - unsigned i; - int status = -1; /* = ERROR */ - - if (maxEval) { - if (r->num_points > maxEval) - return status; /* ERROR */ - maxIter = (maxEval - r->num_points) / (2 * r->num_points); - } - else - maxIter = UINT_MAX; - - regions = heap_alloc(1); - - heap_push(®ions, eval_region(make_region(h), f, fdata, r)); - /* another possibility is to specify some non-adaptive subdivisions: - if (initialRegions != 1) - partition(h, initialRegions, EQUIDISTANT, ®ions, f,fdata, r); */ - - for (i = 0; i < maxIter; ++i) { - region R, R2; - if (regions.ee.err <= reqAbsError - || relError(regions.ee) <= reqRelError) { - status = 0; /* converged! */ - break; - } - R = heap_pop(®ions); /* get worst region */ - cut_region(&R, &R2); - heap_push(®ions, eval_region(R, f, fdata, r)); - heap_push(®ions, eval_region(R2, f, fdata, r)); - } - - ee->val = ee->err = 0; /* re-sum integral and errors */ - for (i = 0; i < regions.n; ++i) { - ee->val += regions.items[i].ee.val; - ee->err += regions.items[i].ee.err; - destroy_region(®ions.items[i]); - } - /* printf("regions.nalloc = %d\n", regions.nalloc); */ - heap_free(®ions); - - return status; -} - -static int adapt_integrate(integrand f, void *fdata, - unsigned dim, const double *xmin, const double *xmax, - unsigned maxEval, double reqAbsError, double reqRelError, - num *val, double *err) -{ - rule *r; - hypercube h; - esterr ee; - int status; - - if (dim == 0) { /* trivial integration */ - *val = f(0, xmin, fdata); - *err = 0; - return 0; - } - r = dim == 1 ? make_rule15gauss(dim) : make_rule75genzmalik(dim); - if (!r) { *val = 0; *err = HUGE_VAL; return -2; /* ERROR */ } - h = make_hypercube_range(dim, xmin, xmax); - status = ruleadapt_integrate(r, f, fdata, &h, - maxEval, reqAbsError, reqRelError, - &ee); - *val = ee.val; - *err = ee.err; - destroy_hypercube(&h); - destroy_rule(r); - return status; +static int ruleadapt_integrate(rule *r, integrand f, void *fdata, const hypercube *h, + unsigned maxEval, double reqAbsError, double reqRelError, + esterr *ee) { + unsigned maxIter; /* maximum number of adaptive subdivisions */ + heap regions; + unsigned i; + int status = -1; /* = ERROR */ + + if (maxEval) { + if (r->num_points > maxEval) return status; /* ERROR */ + maxIter = (maxEval - r->num_points) / (2 * r->num_points); + } + else + maxIter = UINT_MAX; + + regions = heap_alloc(1); + + heap_push(®ions, eval_region(make_region(h), f, fdata, r)); + /* another possibility is to specify some non-adaptive subdivisions: + if (initialRegions != 1) + partition(h, initialRegions, EQUIDISTANT, ®ions, f,fdata, r); */ + + for (i = 0; i < maxIter; ++i) { + region R, R2; + if (regions.ee.err <= reqAbsError || relError(regions.ee) <= reqRelError) { + status = 0; /* converged! */ + break; + } + R = heap_pop(®ions); /* get worst region */ + cut_region(&R, &R2); + heap_push(®ions, eval_region(R, f, fdata, r)); + heap_push(®ions, eval_region(R2, f, fdata, r)); + } + + ee->val = ee->err = 0; /* re-sum integral and errors */ + for (i = 0; i < regions.n; ++i) { + ee->val += regions.items[i].ee.val; + ee->err += regions.items[i].ee.err; + destroy_region(®ions.items[i]); + } + /* printf("regions.nalloc = %d\n", regions.nalloc); */ + heap_free(®ions); + + return status; +} + +static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, + const double *xmax, unsigned maxEval, double reqAbsError, + double reqRelError, num *val, double *err) { + rule *r; + hypercube h; + esterr ee; + int status; + + if (dim == 0) { /* trivial integration */ + *val = f(0, xmin, fdata); + *err = 0; + return 0; + } + r = dim == 1 ? make_rule15gauss(dim) : make_rule75genzmalik(dim); + if (!r) { + *val = 0; + *err = HUGE_VAL; + return -2; /* ERROR */ + } + h = make_hypercube_range(dim, xmin, xmax); + status = ruleadapt_integrate(r, f, fdata, &h, maxEval, reqAbsError, reqRelError, &ee); + *val = ee.val; + *err = ee.err; + destroy_hypercube(&h); + destroy_rule(r); + return status; } /***************************************************************************/ @@ -759,190 +713,163 @@ const double radius = 0.50124145262344534123412; /* random */ /* Simple constant function */ -num -fconst (double x[], size_t dim, void *params) -{ - return 1; -} +num fconst(double x[], size_t dim, void *params) { return 1; } /*** f0, f1, f2, and f3 are test functions from the Monte-Carlo integration routines in GSL 1.6 (monte/test.c). Copyright (c) 1996-2000 Michael Booth, GNU GPL. ****/ /* Simple product function */ -num f0 (unsigned dim, const double *x, void *params) -{ - double prod = 1.0; - unsigned int i; - for (i = 0; i < dim; ++i) - prod *= 2.0 * x[i]; - return prod; +num f0(unsigned dim, const double *x, void *params) { + double prod = 1.0; + unsigned int i; + for (i = 0; i < dim; ++i) + prod *= 2.0 * x[i]; + return prod; } /* Gaussian centered at 1/2. */ -num f1 (unsigned dim, const double *x, void *params) -{ - double a = *(double *)params; - double sum = 0.; - unsigned int i; - for (i = 0; i < dim; i++) { - double dx = x[i] - 0.5; - sum += dx * dx; - } - return (pow (M_2_SQRTPI / (2. * a), (double) dim) * - exp (-sum / (a * a))); +num f1(unsigned dim, const double *x, void *params) { + double a = *(double *)params; + double sum = 0.; + unsigned int i; + for (i = 0; i < dim; i++) { + double dx = x[i] - 0.5; + sum += dx * dx; + } + return (pow(M_2_SQRTPI / (2. * a), (double)dim) * exp(-sum / (a * a))); } /* double gaussian */ -num f2 (unsigned dim, const double *x, void *params) -{ - double a = *(double *)params; - double sum1 = 0.; - double sum2 = 0.; - unsigned int i; - for (i = 0; i < dim; i++) { - double dx1 = x[i] - 1. / 3.; - double dx2 = x[i] - 2. / 3.; - sum1 += dx1 * dx1; - sum2 += dx2 * dx2; - } - return 0.5 * pow (M_2_SQRTPI / (2. * a), dim) - * (exp (-sum1 / (a * a)) + exp (-sum2 / (a * a))); +num f2(unsigned dim, const double *x, void *params) { + double a = *(double *)params; + double sum1 = 0.; + double sum2 = 0.; + unsigned int i; + for (i = 0; i < dim; i++) { + double dx1 = x[i] - 1. / 3.; + double dx2 = x[i] - 2. / 3.; + sum1 += dx1 * dx1; + sum2 += dx2 * dx2; + } + return 0.5 * pow(M_2_SQRTPI / (2. * a), dim) * (exp(-sum1 / (a * a)) + exp(-sum2 / (a * a))); } /* Tsuda's example */ -num f3 (unsigned dim, const double *x, void *params) -{ - double c = *(double *)params; - double prod = 1.; - unsigned int i; - for (i = 0; i < dim; i++) - prod *= c / (c + 1) * pow((c + 1) / (c + x[i]), 2.0); - return prod; +num f3(unsigned dim, const double *x, void *params) { + double c = *(double *)params; + double prod = 1.; + unsigned int i; + for (i = 0; i < dim; i++) + prod *= c / (c + 1) * pow((c + 1) / (c + x[i]), 2.0); + return prod; } /*** end of GSL test functions ***/ -num f_test(unsigned dim, const double *x, void *data) -{ - double val; - unsigned i; - ++count; - switch (which_integrand) { - case 0: /* simple smooth (separable) objective: prod. cos(x[i]). */ - val = 1; - for (i = 0; i < dim; ++i) - val *= cos(x[i]); - break; - case 1: { /* integral of exp(-x^2), rescaled to (0,infinity) limits */ - double scale = 1.0; - val = 0; - for (i = 0; i < dim; ++i) { - double z = (1 - x[i]) / x[i]; - val += z * z; - scale *= M_2_SQRTPI / (x[i] * x[i]); - } - val = exp(-val) * scale; - break; - } - case 2: /* discontinuous objective: volume of hypersphere */ - val = 0; - for (i = 0; i < dim; ++i) - val += x[i] * x[i]; - val = val < radius * radius; - break; - case 3: - val = f0(dim, x, data); - break; - case 4: - val = f1(dim, x, data); - break; - case 5: - val = f2(dim, x, data); - break; - case 6: - val = f3(dim, x, data); - break; - default: - fprintf(stderr, "unknown integrand %d\n", which_integrand); - exit(EXIT_FAILURE); - } - /* if (count < 100) printf("%d: f(%g, ...) = %g\n", count, x[0], val); */ - return val; +num f_test(unsigned dim, const double *x, void *data) { + double val; + unsigned i; + ++count; + switch (which_integrand) { + case 0: /* simple smooth (separable) objective: prod. cos(x[i]). */ + val = 1; + for (i = 0; i < dim; ++i) + val *= cos(x[i]); + break; + case 1: { /* integral of exp(-x^2), rescaled to (0,infinity) limits */ + double scale = 1.0; + val = 0; + for (i = 0; i < dim; ++i) { + double z = (1 - x[i]) / x[i]; + val += z * z; + scale *= M_2_SQRTPI / (x[i] * x[i]); + } + val = exp(-val) * scale; + break; + } + case 2: /* discontinuous objective: volume of hypersphere */ + val = 0; + for (i = 0; i < dim; ++i) + val += x[i] * x[i]; + val = val < radius * radius; + break; + case 3: val = f0(dim, x, data); break; + case 4: val = f1(dim, x, data); break; + case 5: val = f2(dim, x, data); break; + case 6: val = f3(dim, x, data); break; + default: fprintf(stderr, "unknown integrand %d\n", which_integrand); exit(EXIT_FAILURE); + } + /* if (count < 100) printf("%d: f(%g, ...) = %g\n", count, x[0], val); */ + return val; } /* surface area of n-dimensional unit hypersphere */ -static double S(unsigned n) -{ - double val; - int fact = 1; - if (n % 2 == 0) { /* n even */ - val = 2 * pow(M_PI, n * 0.5); - n = n / 2; - while (n > 1) fact *= (n -= 1); - val /= fact; - } - else { /* n odd */ - val = (1 << (n/2 + 1)) * pow(M_PI, n/2); - while (n > 2) fact *= (n -= 2); - val /= fact; - } - return val; +static double S(unsigned n) { + double val; + int fact = 1; + if (n % 2 == 0) { /* n even */ + val = 2 * pow(M_PI, n * 0.5); + n = n / 2; + while (n > 1) + fact *= (n -= 1); + val /= fact; + } + else { /* n odd */ + val = (1 << (n / 2 + 1)) * pow(M_PI, n / 2); + while (n > 2) + fact *= (n -= 2); + val /= fact; + } + return val; } static num exact_integral(unsigned dim, const double *xmax) { - unsigned i; - double val; - switch(which_integrand) { - case 0: - val = 1; - for (i = 0; i < dim; ++i) - val *= sin(xmax[i]); - break; - case 2: - val = dim == 0 ? 1 : S(dim) * pow(radius * 0.5, dim) / dim; - break; - default: - val = 1.0; - } - return val; -} - -int main(int argc, char **argv) -{ - double *xmin, *xmax; - double tol, err; - num val; - unsigned i, dim, maxEval; - double fdata; - - dim = argc > 1 ? atoi(argv[1]) : 2; - tol = argc > 2 ? atof(argv[2]) : 1e-2; - which_integrand = argc > 3 ? atoi(argv[3]) : 0; - maxEval = argc > 4 ? atoi(argv[4]) : 0; - - fdata = which_integrand == 6 ? (1.0 + sqrt (10.0)) / 9.0 : 0.1; - - xmin = (double *) malloc(dim * sizeof(double)); - xmax = (double *) malloc(dim * sizeof(double)); - for (i = 0; i < dim; ++i) { - xmin[i] = 0; - xmax[i] = 1 + (which_integrand >= 1 ? 0 : 0.4 * sin(i)); - } - - printf("%u-dim integral, tolerance = %g, integrand = %d\n", - dim, tol, which_integrand); - adapt_integrate(f_test, &fdata, - dim, xmin, xmax, - maxEval, 0, tol, &val, &err); - printf("integration val = %g, est. err = %g, true err = %g\n", - val, err, num_abs(val - exact_integral(dim, xmax))); - printf("#evals = %d\n", count); + unsigned i; + double val; + switch (which_integrand) { + case 0: + val = 1; + for (i = 0; i < dim; ++i) + val *= sin(xmax[i]); + break; + case 2: val = dim == 0 ? 1 : S(dim) * pow(radius * 0.5, dim) / dim; break; + default: val = 1.0; + } + return val; +} + +int main(int argc, char **argv) { + double *xmin, *xmax; + double tol, err; + num val; + unsigned i, dim, maxEval; + double fdata; + + dim = argc > 1 ? atoi(argv[1]) : 2; + tol = argc > 2 ? atof(argv[2]) : 1e-2; + which_integrand = argc > 3 ? atoi(argv[3]) : 0; + maxEval = argc > 4 ? atoi(argv[4]) : 0; + + fdata = which_integrand == 6 ? (1.0 + sqrt(10.0)) / 9.0 : 0.1; + + xmin = (double *)malloc(dim * sizeof(double)); + xmax = (double *)malloc(dim * sizeof(double)); + for (i = 0; i < dim; ++i) { + xmin[i] = 0; + xmax[i] = 1 + (which_integrand >= 1 ? 0 : 0.4 * sin(i)); + } + + printf("%u-dim integral, tolerance = %g, integrand = %d\n", dim, tol, which_integrand); + adapt_integrate(f_test, &fdata, dim, xmin, xmax, maxEval, 0, tol, &val, &err); + printf("integration val = %g, est. err = %g, true err = %g\n", val, err, + num_abs(val - exact_integral(dim, xmax))); + printf("#evals = %d\n", count); - free(xmax); - free(xmin); + free(xmax); + free(xmin); - return 0; + return 0; } #else @@ -950,92 +877,79 @@ /*************************************************************************/ /* libctl interface */ -static int adapt_integrate(integrand f, void *fdata, - unsigned dim, const double *xmin, const double *xmax, - unsigned maxEval, - double reqAbsError, double reqRelError, - num *val, double *err); +static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, + const double *xmax, unsigned maxEval, double reqAbsError, + double reqRelError, num *val, double *err); typedef struct { - cmultivar_func f; - void *fdata; + cmultivar_func f; + void *fdata; } cnum_wrap_data; -static num cnum_wrap(unsigned ndim, const double *x, void *fdata_) -{ - cnum_wrap_data *fdata = (cnum_wrap_data *) fdata_; - cnumber val = fdata->f(ndim, (double *) x, fdata->fdata); - return (cnumber_re(val) + I*cnumber_im(val)); -} - -cnumber cadaptive_integration(cmultivar_func f, number *xmin, number *xmax, - integer n, void *fdata, - number abstol, number reltol, integer maxnfe, - number *esterr, integer *errflag) -{ - num val; - cnum_wrap_data wdata; - wdata.f = f; wdata.fdata = fdata; - *errflag = adapt_integrate(cnum_wrap, &wdata, n, xmin, xmax, - maxnfe, abstol, reltol, &val, esterr); - return make_cnumber(creal(val), cimag(val)); -} - -static cnumber cf_scm_wrapper(integer n, number *x, void *f_scm_p) -{ - SCM *f_scm = (SCM *) f_scm_p; - return scm2cnumber(gh_call1(*f_scm, make_number_list(n, x))); -} - -SCM cadaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, - SCM abstol_scm, SCM reltol_scm, SCM maxnfe_scm) -{ - integer n, maxnfe, errflag, i; - number *xmin, *xmax, abstol, reltol; - cnumber integral; - - n = list_length(xmin_scm); - abstol = fabs(ctl_convert_number_to_c(abstol_scm)); - reltol = fabs(ctl_convert_number_to_c(reltol_scm)); - maxnfe = ctl_convert_integer_to_c(maxnfe_scm); - - if (list_length(xmax_scm) != n) { - fprintf(stderr, "adaptive_integration: xmin/xmax dimension mismatch\n"); - return SCM_UNDEFINED; - } - - xmin = (number*) malloc(sizeof(number) * n); - xmax = (number*) malloc(sizeof(number) * n); - if (!xmin || !xmax) { - fprintf(stderr, "adaptive_integration: error, out of memory!\n"); - exit(EXIT_FAILURE); - } - - for (i = 0; i < n; ++i) { - xmin[i] = number_list_ref(xmin_scm, i); - xmax[i] = number_list_ref(xmax_scm, i); - } - - integral = cadaptive_integration(cf_scm_wrapper, xmin, xmax, n, &f_scm, - abstol, reltol, maxnfe, - &abstol, &errflag); - - free(xmax); - free(xmin); - - switch (errflag) { - case 3: - fprintf(stderr, "adaptive_integration: invalid inputs\n"); - return SCM_UNDEFINED; - case 1: - fprintf(stderr, "adaptive_integration: maxnfe too small\n"); - break; - case 2: - fprintf(stderr, "adaptive_integration: lenwork too small\n"); - break; - } +static num cnum_wrap(unsigned ndim, const double *x, void *fdata_) { + cnum_wrap_data *fdata = (cnum_wrap_data *)fdata_; + cnumber val = fdata->f(ndim, (double *)x, fdata->fdata); + return (cnumber_re(val) + I * cnumber_im(val)); +} + +cnumber cadaptive_integration(cmultivar_func f, number *xmin, number *xmax, integer n, void *fdata, + number abstol, number reltol, integer maxnfe, number *esterr, + integer *errflag) { + num val; + cnum_wrap_data wdata; + wdata.f = f; + wdata.fdata = fdata; + *errflag = + adapt_integrate(cnum_wrap, &wdata, n, xmin, xmax, maxnfe, abstol, reltol, &val, esterr); + return make_cnumber(creal(val), cimag(val)); +} + +static cnumber cf_scm_wrapper(integer n, number *x, void *f_scm_p) { + SCM *f_scm = (SCM *)f_scm_p; + return scm2cnumber(gh_call1(*f_scm, make_number_list(n, x))); +} + +SCM cadaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, SCM abstol_scm, SCM reltol_scm, + SCM maxnfe_scm) { + integer n, maxnfe, errflag, i; + number *xmin, *xmax, abstol, reltol; + cnumber integral; + + n = list_length(xmin_scm); + abstol = fabs(ctl_convert_number_to_c(abstol_scm)); + reltol = fabs(ctl_convert_number_to_c(reltol_scm)); + maxnfe = ctl_convert_integer_to_c(maxnfe_scm); + + if (list_length(xmax_scm) != n) { + fprintf(stderr, "adaptive_integration: xmin/xmax dimension mismatch\n"); + return SCM_UNDEFINED; + } + + xmin = (number *)malloc(sizeof(number) * n); + xmax = (number *)malloc(sizeof(number) * n); + if (!xmin || !xmax) { + fprintf(stderr, "adaptive_integration: error, out of memory!\n"); + exit(EXIT_FAILURE); + } + + for (i = 0; i < n; ++i) { + xmin[i] = number_list_ref(xmin_scm, i); + xmax[i] = number_list_ref(xmax_scm, i); + } + + integral = cadaptive_integration(cf_scm_wrapper, xmin, xmax, n, &f_scm, abstol, reltol, maxnfe, + &abstol, &errflag); + + free(xmax); + free(xmin); + + switch (errflag) { + case 3: fprintf(stderr, "adaptive_integration: invalid inputs\n"); return SCM_UNDEFINED; + case 1: fprintf(stderr, "adaptive_integration: maxnfe too small\n"); break; + case 2: fprintf(stderr, "adaptive_integration: lenwork too small\n"); break; + } - return gh_cons(cnumber2scm(integral), ctl_convert_number_to_scm(abstol)); + return gh_cons(cnumber2scm(integral), ctl_convert_number_to_scm(abstol)); } #endif diff -Nru libctl-4.4.0/src/ctl.c libctl-4.5.0/src/ctl.c --- libctl-4.4.0/src/ctl.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/src/ctl.c 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -36,18 +36,17 @@ #endif #if defined(HAVE_NO_GH) -# define gh_length(x) scm_to_long(scm_length(x)) +#define gh_length(x) scm_to_long(scm_length(x)) #elif !defined(HAVE_GH_LENGTH) -# define gh_length gh_list_length +#define gh_length gh_list_length #endif #if defined(HAVE_NO_GH) -# define list_ref(l,index) scm_list_ref(l,scm_from_int(index)) +#define list_ref(l, index) scm_list_ref(l, scm_from_int(index)) #elif !defined(HAVE_GH_LIST_REF) /* Guile 1.2 doesn't have the gh_list_ref function. Sigh. */ /* Note: index must be in [0,list_length(l) - 1]. We don't check! */ -static SCM list_ref(list l, int index) -{ +static SCM list_ref(list l, int index) { SCM cur = SCM_UNSPECIFIED, rest = l; while (index >= 0) { @@ -58,15 +57,15 @@ return cur; } #else /* HAVE_GH_LIST_REF */ -#define list_ref(l,index) gh_list_ref(l,gh_int2scm(index)) +#define list_ref(l, index) gh_list_ref(l, gh_int2scm(index)) #endif #if defined(HAVE_NO_GH) -# define vector_ref(v,i) scm_c_vector_ref(v,i) +#define vector_ref(v, i) scm_c_vector_ref(v, i) #elif !defined(HAVE_GH_VECTOR_REF) -# define vector_ref(v,i) gh_vref(v,gh_int2scm(i)) +#define vector_ref(v, i) gh_vref(v, gh_int2scm(i)) #else -# define vector_ref(v,i) gh_vector_ref(v,gh_int2scm(i)) +#define vector_ref(v, i) gh_vector_ref(v, gh_int2scm(i)) #endif /**************************************************************************/ @@ -76,8 +75,7 @@ from include.scm, or defaults to gh_load if this function isn't defined. */ -void ctl_include(const char *filename) -{ +void ctl_include(const char *filename) { SCM include_proc = gh_lookup("include"); if (include_proc == SCM_UNDEFINED) gh_load(filename); @@ -90,54 +88,48 @@ } /* convert a pathname into one relative to the current include dir */ -char *ctl_fix_path(const char *path) -{ - char *newpath; - if (path[0] != '/') { - SCM include_dir = gh_lookup("include-dir"); - if (include_dir != SCM_UNDEFINED) { - char *dir = ctl_convert_string_to_c(include_dir); - newpath = (char *) malloc(sizeof(char) * (strlen(dir) + - strlen(path) + 2)); - strcpy(newpath, dir); - free(dir); - if (newpath[0] && newpath[strlen(newpath)-1] != '/') - strcat(newpath, "/"); - strcat(newpath, path); - return newpath; - } - } - newpath = (char *) malloc(sizeof(char) * (strlen(path) + 1)); - strcpy(newpath, path); - return newpath; +char *ctl_fix_path(const char *path) { + char *newpath; + if (path[0] != '/') { + SCM include_dir = gh_lookup("include-dir"); + if (include_dir != SCM_UNDEFINED) { + char *dir = ctl_convert_string_to_c(include_dir); + newpath = (char *)malloc(sizeof(char) * (strlen(dir) + strlen(path) + 2)); + strcpy(newpath, dir); + free(dir); + if (newpath[0] && newpath[strlen(newpath) - 1] != '/') strcat(newpath, "/"); + strcat(newpath, path); + return newpath; + } + } + newpath = (char *)malloc(sizeof(char) * (strlen(path) + 1)); + strcpy(newpath, path); + return newpath; } /**************************************************************************/ /* type conversion */ -vector3 scm2vector3(SCM sv) -{ +vector3 scm2vector3(SCM sv) { vector3 v; - v.x = ctl_convert_number_to_c(vector_ref(sv,0)); - v.y = ctl_convert_number_to_c(vector_ref(sv,1)); - v.z = ctl_convert_number_to_c(vector_ref(sv,2)); + v.x = ctl_convert_number_to_c(vector_ref(sv, 0)); + v.y = ctl_convert_number_to_c(vector_ref(sv, 1)); + v.z = ctl_convert_number_to_c(vector_ref(sv, 2)); return v; } -matrix3x3 scm2matrix3x3(SCM sm) -{ +matrix3x3 scm2matrix3x3(SCM sm) { matrix3x3 m; - m.c0 = scm2vector3(vector_ref(sm,0)); - m.c1 = scm2vector3(vector_ref(sm,1)); - m.c2 = scm2vector3(vector_ref(sm,2)); + m.c0 = scm2vector3(vector_ref(sm, 0)); + m.c1 = scm2vector3(vector_ref(sm, 1)); + m.c2 = scm2vector3(vector_ref(sm, 2)); return m; } -static SCM make_vector3(SCM x, SCM y, SCM z) -{ +static SCM make_vector3(SCM x, SCM y, SCM z) { SCM vscm; vscm = scm_c_make_vector(3, SCM_UNSPECIFIED); #ifdef SCM_SIMPLE_VECTOR_SET @@ -146,91 +138,76 @@ SCM_SIMPLE_VECTOR_SET(vscm, 2, z); #else { - SCM *data; - data = SCM_VELTS(vscm); - data[0] = x; - data[1] = y; - data[2] = z; + SCM *data; + data = SCM_VELTS(vscm); + data[0] = x; + data[1] = y; + data[2] = z; } #endif return vscm; } -SCM vector32scm(vector3 v) -{ - return make_vector3(ctl_convert_number_to_scm(v.x), - ctl_convert_number_to_scm(v.y), - ctl_convert_number_to_scm(v.z)); -} - -SCM matrix3x32scm(matrix3x3 m) -{ - return make_vector3(vector32scm(m.c0), - vector32scm(m.c1), - vector32scm(m.c2)); +SCM vector32scm(vector3 v) { + return make_vector3(ctl_convert_number_to_scm(v.x), ctl_convert_number_to_scm(v.y), + ctl_convert_number_to_scm(v.z)); +} + +SCM matrix3x32scm(matrix3x3 m) { + return make_vector3(vector32scm(m.c0), vector32scm(m.c1), vector32scm(m.c2)); } -cnumber scm2cnumber(SCM sx) -{ +cnumber scm2cnumber(SCM sx) { #ifdef HAVE_SCM_COMPLEXP - if (scm_real_p(sx) && !(SCM_COMPLEXP(sx))) - return make_cnumber(ctl_convert_number_to_c(sx), 0.0); - else - return make_cnumber(SCM_COMPLEX_REAL(sx), SCM_COMPLEX_IMAG(sx)); + if (scm_real_p(sx) && !(SCM_COMPLEXP(sx))) + return make_cnumber(ctl_convert_number_to_c(sx), 0.0); + else + return make_cnumber(SCM_COMPLEX_REAL(sx), SCM_COMPLEX_IMAG(sx)); #else - if (scm_real_p(sx) && !(SCM_NIMP(sx) && SCM_INEXP(sx) && SCM_CPLXP(sx))) - return make_cnumber(ctl_convert_number_to_c(sx), 0.0); - else - return make_cnumber(SCM_REALPART(sx), SCM_IMAG(sx)); + if (scm_real_p(sx) && !(SCM_NIMP(sx) && SCM_INEXP(sx) && SCM_CPLXP(sx))) + return make_cnumber(ctl_convert_number_to_c(sx), 0.0); + else + return make_cnumber(SCM_REALPART(sx), SCM_IMAG(sx)); #endif } -SCM cnumber2scm(cnumber x) -{ -#if defined(HAVE_SCM_C_MAKE_RECTANGULAR) /* Guile 1.6.5 */ - return scm_c_make_rectangular(x.re, x.im); /* Guile 1.5 */ +SCM cnumber2scm(cnumber x) { +#if defined(HAVE_SCM_C_MAKE_RECTANGULAR) /* Guile 1.6.5 */ + return scm_c_make_rectangular(x.re, x.im); /* Guile 1.5 */ #elif defined(HAVE_SCM_MAKE_COMPLEX) - return scm_make_complex(x.re, x.im); /* Guile 1.5 */ + return scm_make_complex(x.re, x.im); /* Guile 1.5 */ #else - if (x.im == 0.0) - return ctl_convert_number_to_scm(x.re); - else - return scm_makdbl(x.re, x.im); + if (x.im == 0.0) + return ctl_convert_number_to_scm(x.re); + else + return scm_makdbl(x.re, x.im); #endif } -cvector3 scm2cvector3(SCM sv) -{ - cvector3 v; +cvector3 scm2cvector3(SCM sv) { + cvector3 v; - v.x = scm2cnumber(vector_ref(sv,0)); - v.y = scm2cnumber(vector_ref(sv,1)); - v.z = scm2cnumber(vector_ref(sv,2)); - return v; + v.x = scm2cnumber(vector_ref(sv, 0)); + v.y = scm2cnumber(vector_ref(sv, 1)); + v.z = scm2cnumber(vector_ref(sv, 2)); + return v; } -cmatrix3x3 scm2cmatrix3x3(SCM sm) -{ - cmatrix3x3 m; +cmatrix3x3 scm2cmatrix3x3(SCM sm) { + cmatrix3x3 m; - m.c0 = scm2cvector3(vector_ref(sm,0)); - m.c1 = scm2cvector3(vector_ref(sm,1)); - m.c2 = scm2cvector3(vector_ref(sm,2)); - return m; + m.c0 = scm2cvector3(vector_ref(sm, 0)); + m.c1 = scm2cvector3(vector_ref(sm, 1)); + m.c2 = scm2cvector3(vector_ref(sm, 2)); + return m; } -SCM cvector32scm(cvector3 v) -{ - return make_vector3(cnumber2scm(v.x), - cnumber2scm(v.y), - cnumber2scm(v.z)); +SCM cvector32scm(cvector3 v) { + return make_vector3(cnumber2scm(v.x), cnumber2scm(v.y), cnumber2scm(v.z)); } -SCM cmatrix3x32scm(cmatrix3x3 m) -{ - return make_vector3(cvector32scm(m.c0), - cvector32scm(m.c1), - cvector32scm(m.c2)); +SCM cmatrix3x32scm(cmatrix3x3 m) { + return make_vector3(cvector32scm(m.c0), cvector32scm(m.c1), cvector32scm(m.c2)); } /**************************************************************************/ @@ -239,70 +216,43 @@ /**** Getters ****/ -integer ctl_get_integer(const char *identifier) -{ - return(ctl_convert_integer_to_c(gh_lookup(identifier))); +integer ctl_get_integer(const char *identifier) { + return (ctl_convert_integer_to_c(gh_lookup(identifier))); } -number ctl_get_number(const char *identifier) -{ - return(ctl_convert_number_to_c(gh_lookup(identifier))); +number ctl_get_number(const char *identifier) { + return (ctl_convert_number_to_c(gh_lookup(identifier))); } -cnumber ctl_get_cnumber(const char *identifier) -{ - return(scm2cnumber(gh_lookup(identifier))); -} +cnumber ctl_get_cnumber(const char *identifier) { return (scm2cnumber(gh_lookup(identifier))); } -boolean ctl_get_boolean(const char *identifier) -{ - return(ctl_convert_boolean_to_c(gh_lookup(identifier))); +boolean ctl_get_boolean(const char *identifier) { + return (ctl_convert_boolean_to_c(gh_lookup(identifier))); } -char* ctl_get_string(const char *identifier) -{ - return(ctl_convert_string_to_c(gh_lookup(identifier))); +char *ctl_get_string(const char *identifier) { + return (ctl_convert_string_to_c(gh_lookup(identifier))); } -vector3 ctl_get_vector3(const char *identifier) -{ - return(scm2vector3(gh_lookup(identifier))); -} +vector3 ctl_get_vector3(const char *identifier) { return (scm2vector3(gh_lookup(identifier))); } -matrix3x3 ctl_get_matrix3x3(const char *identifier) -{ - return(scm2matrix3x3(gh_lookup(identifier))); +matrix3x3 ctl_get_matrix3x3(const char *identifier) { + return (scm2matrix3x3(gh_lookup(identifier))); } -cvector3 ctl_get_cvector3(const char *identifier) -{ - return(scm2cvector3(gh_lookup(identifier))); -} +cvector3 ctl_get_cvector3(const char *identifier) { return (scm2cvector3(gh_lookup(identifier))); } -cmatrix3x3 ctl_get_cmatrix3x3(const char *identifier) -{ - return(scm2cmatrix3x3(gh_lookup(identifier))); +cmatrix3x3 ctl_get_cmatrix3x3(const char *identifier) { + return (scm2cmatrix3x3(gh_lookup(identifier))); } -list ctl_get_list(const char *identifier) -{ - return(gh_lookup(identifier)); -} +list ctl_get_list(const char *identifier) { return (gh_lookup(identifier)); } -object ctl_get_object(const char *identifier) -{ - return(gh_lookup(identifier)); -} +object ctl_get_object(const char *identifier) { return (gh_lookup(identifier)); } -function ctl_get_function(const char *identifier) -{ - return(gh_lookup(identifier)); -} +function ctl_get_function(const char *identifier) { return (gh_lookup(identifier)); } -SCM ctl_get_SCM(const char *identifier) -{ - return(gh_lookup(identifier)); -} +SCM ctl_get_SCM(const char *identifier) { return (gh_lookup(identifier)); } /**** Setters ****/ @@ -329,326 +279,225 @@ via scm_c_lookup (which doesn't exist in Guile 1.3.x). */ #if !(defined(HAVE_SCM_VARIABLE_SET_X) && defined(HAVE_SCM_C_LOOKUP)) -# define USE_MY_SYMBOL_SET_X 1 /* use the hack */ +#define USE_MY_SYMBOL_SET_X 1 /* use the hack */ #endif #ifdef USE_MY_SYMBOL_SET_X -static SCM my_symbol_set_x(const char *name, SCM v) -{ - /* code swiped from scm_symbol_value0 and scm_symbol_set_x */ - SCM symbol = scm_intern_obarray_soft(name, strlen (name), scm_symhash, 0); - SCM vcell = scm_sym2vcell (SCM_CAR (symbol), - SCM_CDR (scm_top_level_lookup_closure_var), - SCM_BOOL_F); - if (SCM_FALSEP (vcell)) - return SCM_UNDEFINED; - SCM_SETCDR (vcell, v); - return SCM_UNSPECIFIED; +static SCM my_symbol_set_x(const char *name, SCM v) { + /* code swiped from scm_symbol_value0 and scm_symbol_set_x */ + SCM symbol = scm_intern_obarray_soft(name, strlen(name), scm_symhash, 0); + SCM vcell = scm_sym2vcell(SCM_CAR(symbol), SCM_CDR(scm_top_level_lookup_closure_var), SCM_BOOL_F); + if (SCM_FALSEP(vcell)) return SCM_UNDEFINED; + SCM_SETCDR(vcell, v); + return SCM_UNSPECIFIED; } #endif -static void set_value(const char *identifier, SCM value) -{ -#if defined(USE_SCM_SYMBOL_SET_X) /* worked in Guile 1.1, 1.2 */ - scm_symbol_set_x(SCM_BOOL_F, gh_symbol2scm(identifier), value); +static void set_value(const char *identifier, SCM value) { +#if defined(USE_SCM_SYMBOL_SET_X) /* worked in Guile 1.1, 1.2 */ + scm_symbol_set_x(SCM_BOOL_F, gh_symbol2scm(identifier), value); #elif defined(HAVE_SCM_VARIABLE_SET_X) && defined(HAVE_SCM_C_LOOKUP) - scm_variable_set_x(scm_c_lookup(identifier), value); + scm_variable_set_x(scm_c_lookup(identifier), value); #elif defined(USE_MY_SYMBOL_SET_X) - my_symbol_set_x(identifier, value); + my_symbol_set_x(identifier, value); #endif } -void ctl_set_integer(const char *identifier, integer value) -{ +void ctl_set_integer(const char *identifier, integer value) { set_value(identifier, ctl_convert_integer_to_scm(value)); } -void ctl_set_number(const char *identifier, number value) -{ +void ctl_set_number(const char *identifier, number value) { set_value(identifier, ctl_convert_number_to_scm(value)); } -void ctl_set_cnumber(const char *identifier, cnumber value) -{ +void ctl_set_cnumber(const char *identifier, cnumber value) { set_value(identifier, cnumber2scm(value)); } -void ctl_set_boolean(const char *identifier, boolean value) -{ +void ctl_set_boolean(const char *identifier, boolean value) { set_value(identifier, ctl_convert_boolean_to_scm(value)); } -void ctl_set_string(const char *identifier, const char *value) -{ +void ctl_set_string(const char *identifier, const char *value) { set_value(identifier, ctl_convert_string_to_scm(value)); } -void ctl_set_vector3(const char *identifier, vector3 value) -{ +void ctl_set_vector3(const char *identifier, vector3 value) { set_value(identifier, vector32scm(value)); } -void ctl_set_matrix3x3(const char *identifier, matrix3x3 value) -{ +void ctl_set_matrix3x3(const char *identifier, matrix3x3 value) { set_value(identifier, matrix3x32scm(value)); } -void ctl_set_cvector3(const char *identifier, cvector3 value) -{ +void ctl_set_cvector3(const char *identifier, cvector3 value) { set_value(identifier, cvector32scm(value)); } -void ctl_set_cmatrix3x3(const char *identifier, cmatrix3x3 value) -{ +void ctl_set_cmatrix3x3(const char *identifier, cmatrix3x3 value) { set_value(identifier, cmatrix3x32scm(value)); } -void ctl_set_list(const char *identifier, list value) -{ - set_value(identifier, value); -} +void ctl_set_list(const char *identifier, list value) { set_value(identifier, value); } -void ctl_set_object(const char *identifier, object value) -{ - set_value(identifier, value); -} +void ctl_set_object(const char *identifier, object value) { set_value(identifier, value); } -void ctl_set_function(const char *identifier, function value) -{ - set_value(identifier, value); -} +void ctl_set_function(const char *identifier, function value) { set_value(identifier, value); } -void ctl_set_SCM(const char *identifier, SCM value) -{ - set_value(identifier, value); -} +void ctl_set_SCM(const char *identifier, SCM value) { set_value(identifier, value); } /**************************************************************************/ /* list traversal */ -int list_length(list l) -{ - return(gh_length(l)); -} +int list_length(list l) { return (gh_length(l)); } -integer integer_list_ref(list l, int index) -{ - return(ctl_convert_integer_to_c(list_ref(l,index))); +integer integer_list_ref(list l, int index) { + return (ctl_convert_integer_to_c(list_ref(l, index))); } -number number_list_ref(list l, int index) -{ - return(ctl_convert_number_to_c(list_ref(l,index))); -} +number number_list_ref(list l, int index) { return (ctl_convert_number_to_c(list_ref(l, index))); } -cnumber cnumber_list_ref(list l, int index) -{ - return(scm2cnumber(list_ref(l,index))); -} +cnumber cnumber_list_ref(list l, int index) { return (scm2cnumber(list_ref(l, index))); } -boolean boolean_list_ref(list l, int index) -{ - return(SCM_BOOL_F != list_ref(l,index)); -} +boolean boolean_list_ref(list l, int index) { return (SCM_BOOL_F != list_ref(l, index)); } -char* string_list_ref(list l, int index) -{ - return(ctl_convert_string_to_c(list_ref(l,index))); -} +char *string_list_ref(list l, int index) { return (ctl_convert_string_to_c(list_ref(l, index))); } -vector3 vector3_list_ref(list l, int index) -{ - return(scm2vector3(list_ref(l,index))); -} +vector3 vector3_list_ref(list l, int index) { return (scm2vector3(list_ref(l, index))); } -matrix3x3 matrix3x3_list_ref(list l, int index) -{ - return(scm2matrix3x3(list_ref(l,index))); -} +matrix3x3 matrix3x3_list_ref(list l, int index) { return (scm2matrix3x3(list_ref(l, index))); } -cvector3 cvector3_list_ref(list l, int index) -{ - return(scm2cvector3(list_ref(l,index))); -} +cvector3 cvector3_list_ref(list l, int index) { return (scm2cvector3(list_ref(l, index))); } -cmatrix3x3 cmatrix3x3_list_ref(list l, int index) -{ - return(scm2cmatrix3x3(list_ref(l,index))); -} +cmatrix3x3 cmatrix3x3_list_ref(list l, int index) { return (scm2cmatrix3x3(list_ref(l, index))); } -list list_list_ref(list l, int index) -{ - return(list_ref(l,index)); -} +list list_list_ref(list l, int index) { return (list_ref(l, index)); } -object object_list_ref(list l, int index) -{ - return(list_ref(l,index)); -} +object object_list_ref(list l, int index) { return (list_ref(l, index)); } -function function_list_ref(list l, int index) -{ - return(list_ref(l,index)); -} +function function_list_ref(list l, int index) { return (list_ref(l, index)); } -SCM SCM_list_ref(list l, int index) -{ - return(list_ref(l,index)); -} +SCM SCM_list_ref(list l, int index) { return (list_ref(l, index)); } /**************************************************************************/ /* list creation */ -#define MAKE_LIST(conv) \ -{ \ - int i; \ - list cur_list = SCM_EOL; \ - for (i = num_items - 1; i >= 0; --i) \ - cur_list = gh_cons(conv (items[i]), cur_list); \ - return(cur_list); \ -} \ +#define MAKE_LIST(conv) \ + { \ + int i; \ + list cur_list = SCM_EOL; \ + for (i = num_items - 1; i >= 0; --i) \ + cur_list = gh_cons(conv(items[i]), cur_list); \ + return (cur_list); \ + } #ifdef HAVE_NO_GH -list make_integer_list(int num_items, const integer *items) -MAKE_LIST(scm_from_int) +list make_integer_list(int num_items, const integer *items) MAKE_LIST(scm_from_int) -list make_boolean_list(int num_items, const boolean *items) -MAKE_LIST(scm_from_bool) + list make_boolean_list(int num_items, const boolean *items) MAKE_LIST(scm_from_bool) -list make_string_list(int num_items, const char **items) -MAKE_LIST(scm_from_locale_string) + list make_string_list(int num_items, const char **items) MAKE_LIST(scm_from_locale_string) -list make_number_list(int num_items, const number *items) -MAKE_LIST(scm_from_double) + list make_number_list(int num_items, const number *items) MAKE_LIST(scm_from_double) #else /* ! HAVE_NO_GH */ -list make_integer_list(int num_items, const integer *items) -MAKE_LIST(gh_int2scm) +list make_integer_list(int num_items, const integer *items) MAKE_LIST(gh_int2scm) -list make_boolean_list(int num_items, const boolean *items) -MAKE_LIST(gh_bool2scm) + list make_boolean_list(int num_items, const boolean *items) MAKE_LIST(gh_bool2scm) -list make_string_list(int num_items, const char **items) -MAKE_LIST(gh_str02scm) + list make_string_list(int num_items, const char **items) MAKE_LIST(gh_str02scm) -list make_number_list(int num_items, const number *items) -MAKE_LIST(gh_double2scm) + list make_number_list(int num_items, const number *items) MAKE_LIST(gh_double2scm) #endif /* ! HAVE_NO_GH */ -list make_cnumber_list(int num_items, const cnumber *items) -MAKE_LIST(cnumber2scm) + list make_cnumber_list(int num_items, const cnumber *items) MAKE_LIST(cnumber2scm) -list make_vector3_list(int num_items, const vector3 *items) -MAKE_LIST(vector32scm) + list + make_vector3_list(int num_items, const vector3 *items) MAKE_LIST(vector32scm) -list make_matrix3x3_list(int num_items, const matrix3x3 *items) -MAKE_LIST(matrix3x32scm) + list make_matrix3x3_list(int num_items, const matrix3x3 *items) MAKE_LIST(matrix3x32scm) -list make_cvector3_list(int num_items, const cvector3 *items) -MAKE_LIST(cvector32scm) + list make_cvector3_list(int num_items, const cvector3 *items) MAKE_LIST(cvector32scm) -list make_cmatrix3x3_list(int num_items, const cmatrix3x3 *items) -MAKE_LIST(cmatrix3x32scm) + list + make_cmatrix3x3_list(int num_items, const cmatrix3x3 *items) MAKE_LIST(cmatrix3x32scm) #define NO_CONVERSION -list make_list_list(int num_items, const list *items) -MAKE_LIST(NO_CONVERSION) + list make_list_list(int num_items, const list *items) MAKE_LIST(NO_CONVERSION) -list make_object_list(int num_items, const object *items) -MAKE_LIST(NO_CONVERSION) + list make_object_list(int num_items, const object *items) MAKE_LIST(NO_CONVERSION) -list make_function_list(int num_items, const object *items) -MAKE_LIST(NO_CONVERSION) + list make_function_list(int num_items, const object *items) MAKE_LIST(NO_CONVERSION) -list make_SCM_list(int num_items, const object *items) -MAKE_LIST(NO_CONVERSION) + list make_SCM_list(int num_items, const object *items) MAKE_LIST(NO_CONVERSION) + /**************************************************************************/ -/**************************************************************************/ - -/* object properties */ + /* object properties */ -boolean object_is_member(const char *type_name, object o) -{ - return(SCM_BOOL_F != gh_call2(gh_lookup("object-member?"), - gh_symbol2scm(type_name), - o)); + boolean object_is_member(const char *type_name, object o) { + return (SCM_BOOL_F != gh_call2(gh_lookup("object-member?"), gh_symbol2scm(type_name), o)); } -static SCM object_property_value(object o, const char *property_name) -{ - return(gh_call2(gh_lookup("object-property-value"), - o, - gh_symbol2scm(property_name))); +static SCM object_property_value(object o, const char *property_name) { + return (gh_call2(gh_lookup("object-property-value"), o, gh_symbol2scm(property_name))); } -integer integer_object_property(object o, const char *property_name) -{ - return(ctl_convert_integer_to_c(object_property_value(o,property_name))); +integer integer_object_property(object o, const char *property_name) { + return (ctl_convert_integer_to_c(object_property_value(o, property_name))); } -number number_object_property(object o, const char *property_name) -{ - return(ctl_convert_number_to_c(object_property_value(o,property_name))); +number number_object_property(object o, const char *property_name) { + return (ctl_convert_number_to_c(object_property_value(o, property_name))); } -cnumber cnumber_object_property(object o, const char *property_name) -{ - return(scm2cnumber(object_property_value(o,property_name))); +cnumber cnumber_object_property(object o, const char *property_name) { + return (scm2cnumber(object_property_value(o, property_name))); } -boolean boolean_object_property(object o, const char *property_name) -{ - return(SCM_BOOL_F != object_property_value(o,property_name)); +boolean boolean_object_property(object o, const char *property_name) { + return (SCM_BOOL_F != object_property_value(o, property_name)); } -char* string_object_property(object o, const char *property_name) -{ - return(ctl_convert_string_to_c(object_property_value(o,property_name))); +char *string_object_property(object o, const char *property_name) { + return (ctl_convert_string_to_c(object_property_value(o, property_name))); } -vector3 vector3_object_property(object o, const char *property_name) -{ - return(scm2vector3(object_property_value(o,property_name))); +vector3 vector3_object_property(object o, const char *property_name) { + return (scm2vector3(object_property_value(o, property_name))); } -matrix3x3 matrix3x3_object_property(object o, const char *property_name) -{ - return(scm2matrix3x3(object_property_value(o,property_name))); +matrix3x3 matrix3x3_object_property(object o, const char *property_name) { + return (scm2matrix3x3(object_property_value(o, property_name))); } -cvector3 cvector3_object_property(object o, const char *property_name) -{ - return(scm2cvector3(object_property_value(o,property_name))); +cvector3 cvector3_object_property(object o, const char *property_name) { + return (scm2cvector3(object_property_value(o, property_name))); } -cmatrix3x3 cmatrix3x3_object_property(object o, const char *property_name) -{ - return(scm2cmatrix3x3(object_property_value(o,property_name))); +cmatrix3x3 cmatrix3x3_object_property(object o, const char *property_name) { + return (scm2cmatrix3x3(object_property_value(o, property_name))); } -list list_object_property(object o, const char *property_name) -{ - return(object_property_value(o,property_name)); +list list_object_property(object o, const char *property_name) { + return (object_property_value(o, property_name)); } -object object_object_property(object o, const char *property_name) -{ - return(object_property_value(o,property_name)); +object object_object_property(object o, const char *property_name) { + return (object_property_value(o, property_name)); } -function function_object_property(object o, const char *property_name) -{ - return(object_property_value(o,property_name)); +function function_object_property(object o, const char *property_name) { + return (object_property_value(o, property_name)); } -SCM SCM_object_property(object o, const char *property_name) -{ - return(object_property_value(o,property_name)); +SCM SCM_object_property(object o, const char *property_name) { + return (object_property_value(o, property_name)); } diff -Nru libctl-4.4.0/src/ctl-f77-glue.c libctl-4.5.0/src/ctl-f77-glue.c --- libctl-4.4.0/src/ctl-f77-glue.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/src/ctl-f77-glue.c 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -82,41 +82,27 @@ /* Vector functions: (vector3 can be declared as an array of 3 reals in Fortran) */ -void F77_FUNC(vector3scale,VECTOR3SCALE) - (number *s, vector3 *v, vector3 *vscaled) -{ - *vscaled = vector3_scale(*s,*v); +void F77_FUNC(vector3scale, VECTOR3SCALE)(number *s, vector3 *v, vector3 *vscaled) { + *vscaled = vector3_scale(*s, *v); } -void F77_FUNC(vector3plus,VECTOR3PLUS) - (vector3 *v1, vector3 *v2, vector3 *vresult) -{ - *vresult = vector3_plus(*v1,*v2); +void F77_FUNC(vector3plus, VECTOR3PLUS)(vector3 *v1, vector3 *v2, vector3 *vresult) { + *vresult = vector3_plus(*v1, *v2); } -void F77_FUNC(vector3minus,VECTOR3MINUS) - (vector3 *v1, vector3 *v2, vector3 *vresult) -{ - *vresult = vector3_minus(*v1,*v2); +void F77_FUNC(vector3minus, VECTOR3MINUS)(vector3 *v1, vector3 *v2, vector3 *vresult) { + *vresult = vector3_minus(*v1, *v2); } -void F77_FUNC(vector3cross,VECTOR3CROSS) - (vector3 *v1, vector3 *v2, vector3 *vresult) -{ - *vresult = vector3_cross(*v1,*v2); +void F77_FUNC(vector3cross, VECTOR3CROSS)(vector3 *v1, vector3 *v2, vector3 *vresult) { + *vresult = vector3_cross(*v1, *v2); } -void F77_FUNC(vector3dot,VECTOR3DOT) - (vector3 *v1, vector3 *v2, number *result) -{ - *result = vector3_dot(*v1,*v2); +void F77_FUNC(vector3dot, VECTOR3DOT)(vector3 *v1, vector3 *v2, number *result) { + *result = vector3_dot(*v1, *v2); } -void F77_FUNC(vector3norm,VECTOR3DOT) - (vector3 *v, number *result) -{ - *result = vector3_norm(*v); -} +void F77_FUNC(vector3norm, VECTOR3DOT)(vector3 *v, number *result) { *result = vector3_norm(*v); } /**************************************************************************/ @@ -128,114 +114,104 @@ /* Getters: */ -void F77_FUNC(ctlgetnumber,CTLGETNUMBER) - (fortran_string identifier, int *length, number *result) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlgetnumber, CTLGETNUMBER)(fortran_string identifier, int *length, number *result) { + char *s = fcp2ccp(identifier); + s[*length] = 0; *result = ctl_get_number(s); } -void F77_FUNC(ctlgetinteger,CTLGETINTEGER) - (fortran_string identifier, int *length, integer *result) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlgetinteger, CTLGETINTEGER)(fortran_string identifier, int *length, + integer *result) { + char *s = fcp2ccp(identifier); + s[*length] = 0; *result = ctl_get_integer(s); } -void F77_FUNC(ctlgetboolean,CTLGETBOOLEAN) - (fortran_string identifier, int *length, boolean *result) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlgetboolean, CTLGETBOOLEAN)(fortran_string identifier, int *length, + boolean *result) { + char *s = fcp2ccp(identifier); + s[*length] = 0; *result = ctl_get_boolean(s); } -void F77_FUNC(ctlgetlist,CTLGETLIST) - (fortran_string identifier, int *length, list *result) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlgetlist, CTLGETLIST)(fortran_string identifier, int *length, list *result) { + char *s = fcp2ccp(identifier); + s[*length] = 0; *result = ctl_get_list(s); } -void F77_FUNC(ctlgetobject,CTLGETOBJECT) - (fortran_string identifier, int *length, object *result) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlgetobject, CTLGETOBJECT)(fortran_string identifier, int *length, object *result) { + char *s = fcp2ccp(identifier); + s[*length] = 0; *result = ctl_get_object(s); } -void F77_FUNC(ctlgetvector3,CTLGETVECTOR3) - (fortran_string identifier, int *length, vector3 *result) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlgetvector3, CTLGETVECTOR3)(fortran_string identifier, int *length, + vector3 *result) { + char *s = fcp2ccp(identifier); + s[*length] = 0; *result = ctl_get_vector3(s); } /* ctl_get_string doesn't work perfectly--there is no portable way to set the length of the Fortran string. The length is returned in result_length. */ -void F77_FUNC(ctlgetstring,CTLGETSTRING) - (fortran_string identifier, int *length, - fortran_string result, int *result_length) -{ +void F77_FUNC(ctlgetstring, CTLGETSTRING)(fortran_string identifier, int *length, + fortran_string result, int *result_length) { char *r; - char *s = fcp2ccp(identifier); s[*length] = 0; + char *s = fcp2ccp(identifier); + s[*length] = 0; int len; r = ctl_get_string(s); strncpy(fcp2ccp(result), r, *result_length); - len = (int) strlen(r); - if (*result_length < len) - *result_length = len; + len = (int)strlen(r); + if (*result_length < len) *result_length = len; free(r); } /* Setters: */ -void F77_FUNC(ctlsetnumber,CTLSETNUMBER) - (fortran_string identifier, int *length, number *value) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlsetnumber, CTLSETNUMBER)(fortran_string identifier, int *length, number *value) { + char *s = fcp2ccp(identifier); + s[*length] = 0; ctl_set_number(s, *value); } -void F77_FUNC(ctlsetinteger,CTLSETINTEGER) - (fortran_string identifier, int *length, integer *value) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlsetinteger, CTLSETINTEGER)(fortran_string identifier, int *length, + integer *value) { + char *s = fcp2ccp(identifier); + s[*length] = 0; ctl_set_integer(s, *value); } -void F77_FUNC(ctlsetboolean,CTLSETBOOLEAN) - (fortran_string identifier, int *length, boolean *value) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlsetboolean, CTLSETBOOLEAN)(fortran_string identifier, int *length, + boolean *value) { + char *s = fcp2ccp(identifier); + s[*length] = 0; ctl_set_boolean(s, *value); } -void F77_FUNC(ctlsetlist,CTLSETLIST) - (fortran_string identifier, int *length, list *value) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlsetlist, CTLSETLIST)(fortran_string identifier, int *length, list *value) { + char *s = fcp2ccp(identifier); + s[*length] = 0; ctl_set_list(s, *value); } -void F77_FUNC(ctlsetobject,CTLSETOBJECT) - (fortran_string identifier, int *length, object *value) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlsetobject, CTLSETOBJECT)(fortran_string identifier, int *length, object *value) { + char *s = fcp2ccp(identifier); + s[*length] = 0; ctl_set_object(s, *value); } -void F77_FUNC(ctlsetvector3,CTLSETVECTOR3) - (fortran_string identifier, int *length, vector3 *value) -{ - char *s = fcp2ccp(identifier); s[*length] = 0; +void F77_FUNC(ctlsetvector3, CTLSETVECTOR3)(fortran_string identifier, int *length, + vector3 *value) { + char *s = fcp2ccp(identifier); + s[*length] = 0; ctl_set_vector3(s, *value); } -void F77_FUNC(ctlsetstring,CTLSETSTRING) - (fortran_string identifier, int *length, - fortran_string value, int *value_length) -{ +void F77_FUNC(ctlsetstring, CTLSETSTRING)(fortran_string identifier, int *length, + fortran_string value, int *value_length) { char *s = fcp2ccp(identifier); char *v = fcp2ccp(value); s[*length] = 0; @@ -247,57 +223,40 @@ /* list traversal */ -void F77_FUNC(listlength,LISTLENGTH)(list *l, int *len) -{ - *len = list_length(*l); -} +void F77_FUNC(listlength, LISTLENGTH)(list *l, int *len) { *len = list_length(*l); } -void F77_FUNC(numberlistref,NUMBERLISTREF) - (list *l, int *index, number *value) -{ +void F77_FUNC(numberlistref, NUMBERLISTREF)(list *l, int *index, number *value) { *value = number_list_ref(*l, *index); } -void F77_FUNC(integerlistref,INTEGERLISTREF) - (list *l, int *index, integer *value) -{ +void F77_FUNC(integerlistref, INTEGERLISTREF)(list *l, int *index, integer *value) { *value = integer_list_ref(*l, *index); } -void F77_FUNC(booleanlistref,BOOLEANLISTREF) - (list *l, int *index, boolean *value) -{ +void F77_FUNC(booleanlistref, BOOLEANLISTREF)(list *l, int *index, boolean *value) { *value = boolean_list_ref(*l, *index); } -void F77_FUNC(vector3listref,VECTOR3LISTREF) - (list *l, int *index, vector3 *value) -{ +void F77_FUNC(vector3listref, VECTOR3LISTREF)(list *l, int *index, vector3 *value) { *value = vector3_list_ref(*l, *index); } -void F77_FUNC(listlistref,LISTLISTREF) - (list *l, int *index, list *value) -{ +void F77_FUNC(listlistref, LISTLISTREF)(list *l, int *index, list *value) { *value = list_list_ref(*l, *index); } -void F77_FUNC(objectlistref,OBJECTLISTREF) - (list *l, int *index, object *value) -{ +void F77_FUNC(objectlistref, OBJECTLISTREF)(list *l, int *index, object *value) { *value = object_list_ref(*l, *index); } -void F77_FUNC(stringlistref,STRINGLISTREF) - (list *l, int *index, fortran_string value, int *value_length) -{ +void F77_FUNC(stringlistref, STRINGLISTREF)(list *l, int *index, fortran_string value, + int *value_length) { char *v; int len; v = string_list_ref(*l, *index); strncpy(fcp2ccp(value), v, *value_length); - len = (int) strlen(v); - if (*value_length < len) - *value_length = len; + len = (int)strlen(v); + if (*value_length < len) *value_length = len; free(v); } @@ -305,39 +264,27 @@ /* list creation */ -void F77_FUNC(makenumberlist,MAKENUMBERLIST) - (int *num_items, number *items, list *result) -{ +void F77_FUNC(makenumberlist, MAKENUMBERLIST)(int *num_items, number *items, list *result) { *result = make_number_list(*num_items, items); } -void F77_FUNC(makeintegerlist,MAKEINTEGERLIST) - (int *num_items, integer *items, list *result) -{ +void F77_FUNC(makeintegerlist, MAKEINTEGERLIST)(int *num_items, integer *items, list *result) { *result = make_integer_list(*num_items, items); } -void F77_FUNC(makebooleanlist,MAKEBOOLEANLIST) - (int *num_items, boolean *items, list *result) -{ +void F77_FUNC(makebooleanlist, MAKEBOOLEANLIST)(int *num_items, boolean *items, list *result) { *result = make_boolean_list(*num_items, items); } -void F77_FUNC(makevector3list,MAKEVECTOR3LIST) - (int *num_items, vector3 *items, list *result) -{ +void F77_FUNC(makevector3list, MAKEVECTOR3LIST)(int *num_items, vector3 *items, list *result) { *result = make_vector3_list(*num_items, items); } -void F77_FUNC(makelistlist,MAKELISTLIST) - (int *num_items, list *items, list *result) -{ +void F77_FUNC(makelistlist, MAKELISTLIST)(int *num_items, list *items, list *result) { *result = make_list_list(*num_items, items); } -void F77_FUNC(makeobjectlist,MAKEOBJECTLIST) - (int *num_items, object *items, list *result) -{ +void F77_FUNC(makeobjectlist, MAKEOBJECTLIST)(int *num_items, object *items, list *result) { *result = make_object_list(*num_items, items); } @@ -347,67 +294,66 @@ /* object properties */ -void F77_FUNC(objectismember,OBJECTISMEMBER) - (fortran_string type_name, int *length, object *o, boolean *result) -{ - char *s = fcp2ccp(type_name); s[*length] = 0; - *result = object_is_member(s,*o); +void F77_FUNC(objectismember, OBJECTISMEMBER)(fortran_string type_name, int *length, object *o, + boolean *result) { + char *s = fcp2ccp(type_name); + s[*length] = 0; + *result = object_is_member(s, *o); } -void F77_FUNC(numberobjectproperty,NUMBEROBJECTPROPERTY) - (object *o, fortran_string property_name, int *length, number *result) -{ - char *s = fcp2ccp(property_name); s[*length] = 0; - *result = number_object_property(*o,s); +void F77_FUNC(numberobjectproperty, NUMBEROBJECTPROPERTY)(object *o, fortran_string property_name, + int *length, number *result) { + char *s = fcp2ccp(property_name); + s[*length] = 0; + *result = number_object_property(*o, s); } -void F77_FUNC(integerobjectproperty,INTEGEROBJECTPROPERTY) - (object *o, fortran_string property_name, int *length, integer *result) -{ - char *s = fcp2ccp(property_name); s[*length] = 0; - *result = integer_object_property(*o,s); +void F77_FUNC(integerobjectproperty, INTEGEROBJECTPROPERTY)(object *o, fortran_string property_name, + int *length, integer *result) { + char *s = fcp2ccp(property_name); + s[*length] = 0; + *result = integer_object_property(*o, s); } -void F77_FUNC(booleanobjectproperty,BOOLEANOBJECTPROPERTY) - (object *o, fortran_string property_name, int *length, boolean *result) -{ - char *s = fcp2ccp(property_name); s[*length] = 0; - *result = boolean_object_property(*o,s); +void F77_FUNC(booleanobjectproperty, BOOLEANOBJECTPROPERTY)(object *o, fortran_string property_name, + int *length, boolean *result) { + char *s = fcp2ccp(property_name); + s[*length] = 0; + *result = boolean_object_property(*o, s); } -void F77_FUNC(vector3objectproperty,VECTOR3OBJECTPROPERTY) - (object *o, fortran_string property_name, int *length, vector3 *result) -{ - char *s = fcp2ccp(property_name); s[*length] = 0; - *result = vector3_object_property(*o,s); +void F77_FUNC(vector3objectproperty, VECTOR3OBJECTPROPERTY)(object *o, fortran_string property_name, + int *length, vector3 *result) { + char *s = fcp2ccp(property_name); + s[*length] = 0; + *result = vector3_object_property(*o, s); } -void F77_FUNC(listobjectproperty,LISTOBJECTPROPERTY) - (object *o, fortran_string property_name, int *length, list *result) -{ - char *s = fcp2ccp(property_name); s[*length] = 0; - *result = list_object_property(*o,s); +void F77_FUNC(listobjectproperty, LISTOBJECTPROPERTY)(object *o, fortran_string property_name, + int *length, list *result) { + char *s = fcp2ccp(property_name); + s[*length] = 0; + *result = list_object_property(*o, s); } -void F77_FUNC(objectobjectproperty,OBJECTOBJECTPROPERTY) - (object *o, fortran_string property_name, int *length, object *result) -{ - char *s = fcp2ccp(property_name); s[*length] = 0; - *result = object_object_property(*o,s); +void F77_FUNC(objectobjectproperty, OBJECTOBJECTPROPERTY)(object *o, fortran_string property_name, + int *length, object *result) { + char *s = fcp2ccp(property_name); + s[*length] = 0; + *result = object_object_property(*o, s); } -void F77_FUNC(stringobjectproperty,STRINGOBJECTPROPERTY) - (object *o, fortran_string property_name, int *length, - fortran_string result, int *result_length) -{ +void F77_FUNC(stringobjectproperty, STRINGOBJECTPROPERTY)(object *o, fortran_string property_name, + int *length, fortran_string result, + int *result_length) { char *r; - char *s = fcp2ccp(property_name); s[*length] = 0; + char *s = fcp2ccp(property_name); + s[*length] = 0; int len; - r = string_object_property(*o,s); + r = string_object_property(*o, s); strncpy(fcp2ccp(result), r, *result_length); - len = (int) strlen(r); - if (*result_length < len) - *result_length = len; + len = (int)strlen(r); + if (*result_length < len) *result_length = len; free(r); } diff -Nru libctl-4.4.0/src/ctl.h.in libctl-4.5.0/src/ctl.h.in --- libctl-4.4.0/src/ctl.h.in 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/src/ctl.h.in 2020-02-19 18:34:33.000000000 +0000 @@ -24,16 +24,16 @@ #undef HAVE_NO_GH #ifdef HAVE_NO_GH -# include +#include #else -# include +#include #endif #include "ctl-math.h" #ifdef __cplusplus extern "C" { -#endif /* __cplusplus */ +#endif /* __cplusplus */ /**************************************************************************/ /* Configuration options (guessed by configure). @@ -73,7 +73,7 @@ /**************************************************************************/ - /* Basic types: */ +/* Basic types: */ typedef SCM list; typedef SCM function; @@ -82,42 +82,43 @@ /**************************************************************************/ #ifdef HAVE_NO_GH /* use replacements for gh functions */ -# define gh_call0 scm_call_0 -# define gh_call1 scm_call_1 -# define gh_call2 scm_call_2 -# define gh_call3 scm_call_3 -# define gh_apply scm_apply_0 -# define gh_eval_str scm_c_eval_string -# define gh_symbol2scm scm_from_locale_symbol -# define ctl_symbol2newstr(x) scm_to_locale_string(scm_symbol_to_string(x)) -# define gh_cons scm_cons -# define gh_car scm_car -# define gh_cdr scm_cdr -# if SCM_MAJOR_VERSION >= 2 /* get types right for C++, since fc - argument is void* (grrr) in Guile 2.x */ -# define gh_new_procedure(name, fcn, req, opt, rst) scm_c_define_gsubr(name, req, opt, rst, (scm_t_subr) (fcn)) -# else -# define gh_new_procedure(name, fcn, req, opt, rst) scm_c_define_gsubr(name, req, opt, rst, fcn) -# endif -# define gh_repl scm_shell +#define gh_call0 scm_call_0 +#define gh_call1 scm_call_1 +#define gh_call2 scm_call_2 +#define gh_call3 scm_call_3 +#define gh_apply scm_apply_0 +#define gh_eval_str scm_c_eval_string +#define gh_symbol2scm scm_from_locale_symbol +#define ctl_symbol2newstr(x) scm_to_locale_string(scm_symbol_to_string(x)) +#define gh_cons scm_cons +#define gh_car scm_car +#define gh_cdr scm_cdr +#if SCM_MAJOR_VERSION >= 2 /* get types right for C++, since fc \ + argument is void* (grrr) in Guile 2.x */ +#define gh_new_procedure(name, fcn, req, opt, rst) \ + scm_c_define_gsubr(name, req, opt, rst, (scm_t_subr)(fcn)) #else -# define ctl_symbol2newstr(x) gh_symbol2newstr(x, 0) +#define gh_new_procedure(name, fcn, req, opt, rst) scm_c_define_gsubr(name, req, opt, rst, fcn) +#endif +#define gh_repl scm_shell +#else +#define ctl_symbol2newstr(x) gh_symbol2newstr(x, 0) #endif #if !defined(GH_LOOKUP_OK) || defined(HAVE_NO_GH) -# if defined(HAVE_SCM_VARIABLE_REF) && defined(HAVE_SCM_C_LOOKUP) -# define gh_lookup(name) scm_variable_ref(scm_c_lookup(name)) -# else -# define gh_lookup scm_symbol_value0 -# endif +#if defined(HAVE_SCM_VARIABLE_REF) && defined(HAVE_SCM_C_LOOKUP) +#define gh_lookup(name) scm_variable_ref(scm_c_lookup(name)) +#else +#define gh_lookup scm_symbol_value0 +#endif #endif #if !defined(HAVE_GH_LOAD) || defined(HAVE_NO_GH) -# ifdef HAVE_NO_GH -# define gh_load scm_c_primitive_load -# else -# define gh_load gh_eval_file -# endif +#ifdef HAVE_NO_GH +#define gh_load scm_c_primitive_load +#else +#define gh_load gh_eval_file +#endif #endif extern void ctl_include(const char *filename); @@ -126,17 +127,17 @@ /**************************************************************************/ #ifndef HAVE_SCM_C_MAKE_VECTOR -# define scm_c_make_vector(n,fill) scm_make_vector(SCM_MAKINUM(n), fill) +#define scm_c_make_vector(n, fill) scm_make_vector(SCM_MAKINUM(n), fill) #endif /**************************************************************************/ - /* type conversion */ +/* type conversion */ #if !defined(HAVE_GH_BOOL2SCM) && !defined(HAVE_NO_GH) - /* Guile 1.2 is missing gh_bool2scm for some reason; redefine: */ - extern SCM ctl_gh_bool2scm(boolean); -# define gh_bool2scm ctl_gh_bool2scm +/* Guile 1.2 is missing gh_bool2scm for some reason; redefine: */ +extern SCM ctl_gh_bool2scm(boolean); +#define gh_bool2scm ctl_gh_bool2scm #endif extern vector3 scm2vector3(SCM sv); @@ -152,23 +153,23 @@ extern SCM cmatrix3x32scm(cmatrix3x3 m); #ifdef HAVE_NO_GH -# define ctl_convert_number_to_scm(x) scm_from_double(x) -# define ctl_convert_number_to_c(x) scm_to_double(x) -# define ctl_convert_integer_to_scm(x) scm_from_int(x) -# define ctl_convert_integer_to_c(x) scm_to_int(x) -# define ctl_convert_string_to_scm(x) scm_from_locale_string(x) -# define ctl_convert_string_to_c(x) scm_to_locale_string(x) -# define ctl_convert_boolean_to_scm(x) scm_from_bool(x) -# define ctl_convert_boolean_to_c(x) scm_to_bool(x) +#define ctl_convert_number_to_scm(x) scm_from_double(x) +#define ctl_convert_number_to_c(x) scm_to_double(x) +#define ctl_convert_integer_to_scm(x) scm_from_int(x) +#define ctl_convert_integer_to_c(x) scm_to_int(x) +#define ctl_convert_string_to_scm(x) scm_from_locale_string(x) +#define ctl_convert_string_to_c(x) scm_to_locale_string(x) +#define ctl_convert_boolean_to_scm(x) scm_from_bool(x) +#define ctl_convert_boolean_to_c(x) scm_to_bool(x) #else -# define ctl_convert_number_to_scm(x) gh_double2scm(x) -# define ctl_convert_number_to_c(x) gh_scm2double(x) -# define ctl_convert_integer_to_scm(x) gh_int2scm(x) -# define ctl_convert_integer_to_c(x) gh_scm2int(x) -# define ctl_convert_string_to_scm(x) gh_str02scm(x) -# define ctl_convert_string_to_c(x) gh_scm2newstr(x, 0) -# define ctl_convert_boolean_to_scm(x) gh_bool2scm(x) -# define ctl_convert_boolean_to_c(x) gh_scm2bool(x) +#define ctl_convert_number_to_scm(x) gh_double2scm(x) +#define ctl_convert_number_to_c(x) gh_scm2double(x) +#define ctl_convert_integer_to_scm(x) gh_int2scm(x) +#define ctl_convert_integer_to_c(x) gh_scm2int(x) +#define ctl_convert_string_to_scm(x) gh_str02scm(x) +#define ctl_convert_string_to_c(x) gh_scm2newstr(x, 0) +#define ctl_convert_boolean_to_scm(x) gh_bool2scm(x) +#define ctl_convert_boolean_to_c(x) gh_scm2bool(x) #endif #define ctl_convert_cnumber_to_scm(x) cnumber2scm(x) @@ -193,13 +194,13 @@ /**************************************************************************/ - /* variable get/set functions */ +/* variable get/set functions */ extern integer ctl_get_integer(const char *identifier); extern number ctl_get_number(const char *identifier); extern cnumber ctl_get_cnumber(const char *identifier); extern boolean ctl_get_boolean(const char *identifier); -extern char* ctl_get_string(const char *identifier); +extern char *ctl_get_string(const char *identifier); extern vector3 ctl_get_vector3(const char *identifier); extern matrix3x3 ctl_get_matrix3x3(const char *identifier); extern cvector3 ctl_get_cvector3(const char *identifier); @@ -225,14 +226,14 @@ /**************************************************************************/ - /* list traversal */ +/* list traversal */ extern int list_length(list l); extern integer integer_list_ref(list l, int index); extern number number_list_ref(list l, int index); extern cnumber cnumber_list_ref(list l, int index); extern boolean boolean_list_ref(list l, int index); -extern char* string_list_ref(list l, int index); +extern char *string_list_ref(list l, int index); extern vector3 vector3_list_ref(list l, int index); extern matrix3x3 matrix3x3_list_ref(list l, int index); extern cvector3 cvector3_list_ref(list l, int index); @@ -244,7 +245,7 @@ /**************************************************************************/ - /* list creation */ +/* list creation */ extern list make_integer_list(int num_items, const integer *items); extern list make_number_list(int num_items, const number *items); @@ -262,7 +263,7 @@ /**************************************************************************/ - /* object properties */ +/* object properties */ boolean object_is_member(const char *type_name, object o); @@ -270,7 +271,7 @@ extern number number_object_property(object o, const char *property_name); extern cnumber cnumber_object_property(object o, const char *property_name); extern boolean boolean_object_property(object o, const char *property_name); -extern char* string_object_property(object o, const char *property_name); +extern char *string_object_property(object o, const char *property_name); extern vector3 vector3_object_property(object o, const char *property_name); extern matrix3x3 matrix3x3_object_property(object o, const char *property_name); extern cvector3 cvector3_object_property(object o, const char *property_name); @@ -295,42 +296,36 @@ /**************************************************************************/ - /* subplex multi-dimensional minimization routines: */ +/* subplex multi-dimensional minimization routines: */ -extern number subplex(multivar_func f, number *x, integer n, void *fdata, - number tol, integer maxnfe, - number fmin, boolean use_fmin, - number *scale, - integer *nfe, integer *errflag); -extern SCM subplex_scm(SCM f_scm, SCM x_scm, - SCM tol_scm, SCM maxnfe_scm, - SCM fmin_scm, SCM use_fmin_scm, - SCM scale_scm); +extern number subplex(multivar_func f, number *x, integer n, void *fdata, number tol, + integer maxnfe, number fmin, boolean use_fmin, number *scale, integer *nfe, + integer *errflag); +extern SCM subplex_scm(SCM f_scm, SCM x_scm, SCM tol_scm, SCM maxnfe_scm, SCM fmin_scm, + SCM use_fmin_scm, SCM scale_scm); - /* multi-dimensional integration routines */ +/* multi-dimensional integration routines */ -extern SCM adaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, - SCM abstol_scm, SCM reltol_scm, SCM maxnfe_scm); +extern SCM adaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, SCM abstol_scm, + SCM reltol_scm, SCM maxnfe_scm); #ifdef CTL_HAS_COMPLEX_INTEGRATION -typedef cnumber (*cmultivar_func) (integer, number *, void *); +typedef cnumber (*cmultivar_func)(integer, number *, void *); -extern cnumber cadaptive_integration(cmultivar_func f, number *xmin, number *xmax, - integer n, void *fdata, - number abstol, number reltol, - integer maxnfe, - number *esterr, integer *errflag); +extern cnumber cadaptive_integration(cmultivar_func f, number *xmin, number *xmax, integer n, + void *fdata, number abstol, number reltol, integer maxnfe, + number *esterr, integer *errflag); -extern SCM cadaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, - SCM abstol_scm, SCM reltol_scm, SCM maxnfe_scm); +extern SCM cadaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, SCM abstol_scm, + SCM reltol_scm, SCM maxnfe_scm); #endif /* CTL_HAS_COMPLEX_INTEGRATION */ /**************************************************************************/ #ifdef __cplusplus - } /* extern "C" */ -#endif /* __cplusplus */ +} /* extern "C" */ +#endif /* __cplusplus */ #endif /* CTL_H */ diff -Nru libctl-4.4.0/src/ctl-math.c libctl-4.5.0/src/ctl-math.c --- libctl-4.4.0/src/ctl-math.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/src/ctl-math.c 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -30,18 +30,11 @@ /* vector3 and matrix3x3 utilities: */ -number vector3_dot(vector3 v1,vector3 v2) -{ - return (v1.x * v2.x + v1.y * v2.y + v1.z * v2.z); -} +number vector3_dot(vector3 v1, vector3 v2) { return (v1.x * v2.x + v1.y * v2.y + v1.z * v2.z); } -number vector3_norm(vector3 v) -{ - return (sqrt(vector3_dot(v,v))); -} +number vector3_norm(vector3 v) { return (sqrt(vector3_dot(v, v))); } -vector3 vector3_scale(number s, vector3 v) -{ +vector3 vector3_scale(number s, vector3 v) { vector3 vnew; vnew.x = s * v.x; @@ -50,17 +43,15 @@ return vnew; } -vector3 unit_vector3(vector3 v) -{ +vector3 unit_vector3(vector3 v) { number norm = vector3_norm(v); if (norm == 0.0) return v; else - return vector3_scale(1.0/norm, v); + return vector3_scale(1.0 / norm, v); } -vector3 vector3_plus(vector3 v1,vector3 v2) -{ +vector3 vector3_plus(vector3 v1, vector3 v2) { vector3 vnew; vnew.x = v1.x + v2.x; @@ -69,8 +60,7 @@ return vnew; } -vector3 vector3_minus(vector3 v1,vector3 v2) -{ +vector3 vector3_minus(vector3 v1, vector3 v2) { vector3 vnew; vnew.x = v1.x - v2.x; @@ -79,8 +69,7 @@ return vnew; } -vector3 vector3_cross(vector3 v1,vector3 v2) -{ +vector3 vector3_cross(vector3 v1, vector3 v2) { vector3 vnew; vnew.x = v1.y * v2.z - v2.y * v1.z; @@ -89,13 +78,9 @@ return vnew; } -int vector3_equal(vector3 v1, vector3 v2) -{ - return (v1.x == v2.x && v1.y == v2.y && v1.z == v2.z); -} +int vector3_equal(vector3 v1, vector3 v2) { return (v1.x == v2.x && v1.y == v2.y && v1.z == v2.z); } -vector3 matrix3x3_vector3_mult(matrix3x3 m, vector3 v) -{ +vector3 matrix3x3_vector3_mult(matrix3x3 m, vector3 v) { vector3 vnew; vnew.x = m.c0.x * v.x + m.c1.x * v.y + m.c2.x * v.z; @@ -104,8 +89,7 @@ return vnew; } -vector3 matrix3x3_transpose_vector3_mult(matrix3x3 m, vector3 v) -{ +vector3 matrix3x3_transpose_vector3_mult(matrix3x3 m, vector3 v) { vector3 vnew; vnew.x = m.c0.x * v.x + m.c0.y * v.y + m.c0.z * v.z; @@ -114,8 +98,7 @@ return vnew; } -matrix3x3 matrix3x3_mult(matrix3x3 m1, matrix3x3 m2) -{ +matrix3x3 matrix3x3_mult(matrix3x3 m1, matrix3x3 m2) { matrix3x3 m; m.c0.x = m1.c0.x * m2.c0.x + m1.c1.x * m2.c0.y + m1.c2.x * m2.c0.z; @@ -133,181 +116,164 @@ return m; } -matrix3x3 matrix3x3_transpose(matrix3x3 m) -{ - matrix3x3 mt; - - mt.c0.x = m.c0.x; - mt.c1.x = m.c0.y; - mt.c2.x = m.c0.z; - mt.c0.y = m.c1.x; - mt.c1.y = m.c1.y; - mt.c2.y = m.c1.z; - mt.c0.z = m.c2.x; - mt.c1.z = m.c2.y; - mt.c2.z = m.c2.z; - return mt; -} - -number matrix3x3_determinant(matrix3x3 m) -{ - return(m.c0.x*m.c1.y*m.c2.z - m.c2.x*m.c1.y*m.c0.z + - m.c1.x*m.c2.y*m.c0.z + m.c0.y*m.c1.z*m.c2.x - - m.c1.x*m.c0.y*m.c2.z - m.c2.y*m.c1.z*m.c0.x); -} - -matrix3x3 matrix3x3_inverse(matrix3x3 m) -{ - matrix3x3 minv; - number detinv = matrix3x3_determinant(m); - - if (detinv == 0.0) { - fprintf(stderr, "error: singular matrix in matrix3x3_inverse!\n"); - exit(EXIT_FAILURE); - } - detinv = 1.0/detinv; - - minv.c0.x = detinv * (m.c1.y * m.c2.z - m.c2.y * m.c1.z); - minv.c1.y = detinv * (m.c0.x * m.c2.z - m.c2.x * m.c0.z); - minv.c2.z = detinv * (m.c1.y * m.c0.x - m.c0.y * m.c1.x); - - minv.c0.z = detinv * (m.c0.y * m.c1.z - m.c1.y * m.c0.z); - minv.c0.y = -detinv * (m.c0.y * m.c2.z - m.c2.y * m.c0.z); - minv.c1.z = -detinv * (m.c0.x * m.c1.z - m.c1.x * m.c0.z); - - minv.c2.x = detinv * (m.c1.x * m.c2.y - m.c1.y * m.c2.x); - minv.c1.x = -detinv * (m.c1.x * m.c2.z - m.c1.z * m.c2.x); - minv.c2.y = -detinv * (m.c0.x * m.c2.y - m.c0.y * m.c2.x); - - return minv; -} - -int matrix3x3_equal(matrix3x3 m1, matrix3x3 m2) -{ - return (vector3_equal(m1.c0, m2.c0) - && vector3_equal(m1.c1, m2.c1) - && vector3_equal(m1.c2, m2.c2)); -} - -vector3 matrix3x3_row1(matrix3x3 m) -{ - vector3 v; - v.x = m.c0.x; - v.y = m.c1.x; - v.z = m.c2.x; - return v; -} - -vector3 matrix3x3_row2(matrix3x3 m) -{ - vector3 v; - v.x = m.c0.y; - v.y = m.c1.y; - v.z = m.c2.y; - return v; -} - -vector3 matrix3x3_row3(matrix3x3 m) -{ - vector3 v; - v.x = m.c0.z; - v.y = m.c1.z; - v.z = m.c2.z; - return v; +matrix3x3 matrix3x3_transpose(matrix3x3 m) { + matrix3x3 mt; + + mt.c0.x = m.c0.x; + mt.c1.x = m.c0.y; + mt.c2.x = m.c0.z; + mt.c0.y = m.c1.x; + mt.c1.y = m.c1.y; + mt.c2.y = m.c1.z; + mt.c0.z = m.c2.x; + mt.c1.z = m.c2.y; + mt.c2.z = m.c2.z; + return mt; +} + +number matrix3x3_determinant(matrix3x3 m) { + return (m.c0.x * m.c1.y * m.c2.z - m.c2.x * m.c1.y * m.c0.z + m.c1.x * m.c2.y * m.c0.z + + m.c0.y * m.c1.z * m.c2.x - m.c1.x * m.c0.y * m.c2.z - m.c2.y * m.c1.z * m.c0.x); +} + +matrix3x3 matrix3x3_inverse(matrix3x3 m) { + matrix3x3 minv; + number detinv = matrix3x3_determinant(m); + + if (detinv == 0.0) { + fprintf(stderr, "error: singular matrix in matrix3x3_inverse!\n"); + exit(EXIT_FAILURE); + } + detinv = 1.0 / detinv; + + minv.c0.x = detinv * (m.c1.y * m.c2.z - m.c2.y * m.c1.z); + minv.c1.y = detinv * (m.c0.x * m.c2.z - m.c2.x * m.c0.z); + minv.c2.z = detinv * (m.c1.y * m.c0.x - m.c0.y * m.c1.x); + + minv.c0.z = detinv * (m.c0.y * m.c1.z - m.c1.y * m.c0.z); + minv.c0.y = -detinv * (m.c0.y * m.c2.z - m.c2.y * m.c0.z); + minv.c1.z = -detinv * (m.c0.x * m.c1.z - m.c1.x * m.c0.z); + + minv.c2.x = detinv * (m.c1.x * m.c2.y - m.c1.y * m.c2.x); + minv.c1.x = -detinv * (m.c1.x * m.c2.z - m.c1.z * m.c2.x); + minv.c2.y = -detinv * (m.c0.x * m.c2.y - m.c0.y * m.c2.x); + + return minv; +} + +int matrix3x3_equal(matrix3x3 m1, matrix3x3 m2) { + return (vector3_equal(m1.c0, m2.c0) && vector3_equal(m1.c1, m2.c1) && + vector3_equal(m1.c2, m2.c2)); +} + +vector3 matrix3x3_row1(matrix3x3 m) { + vector3 v; + v.x = m.c0.x; + v.y = m.c1.x; + v.z = m.c2.x; + return v; +} + +vector3 matrix3x3_row2(matrix3x3 m) { + vector3 v; + v.x = m.c0.y; + v.y = m.c1.y; + v.z = m.c2.y; + return v; +} + +vector3 matrix3x3_row3(matrix3x3 m) { + vector3 v; + v.x = m.c0.z; + v.y = m.c1.z; + v.z = m.c2.z; + return v; } /**************************************************************************/ /* complex number utilities */ -cnumber make_cnumber(number r, number i) -{ - cnumber c; - c.re = r; c.im = i; - return c; -} - -cnumber cnumber_conj(cnumber c) -{ - return make_cnumber(c.re, -c.im); -} - -int cnumber_equal(cnumber c1, cnumber c2) -{ - return (c1.re == c2.re && c1.im == c2.im); -} - -vector3 cvector3_re(cvector3 cv) -{ - vector3 v; - v.x = cv.x.re; v.y = cv.y.re; v.z = cv.z.re; - return v; -} - -vector3 cvector3_im(cvector3 cv) -{ - vector3 v; - v.x = cv.x.im; v.y = cv.y.im; v.z = cv.z.im; - return v; -} - -cvector3 make_cvector3(vector3 vr, vector3 vi) -{ - cvector3 cv; - cv.x = make_cnumber(vr.x, vi.x); - cv.y = make_cnumber(vr.y, vi.y); - cv.z = make_cnumber(vr.z, vi.z); - return cv; -} - -int cvector3_equal(cvector3 v1, cvector3 v2) -{ - return (vector3_equal(cvector3_re(v1), cvector3_re(v2)) && - vector3_equal(cvector3_im(v1), cvector3_im(v2))); -} - -matrix3x3 cmatrix3x3_re(cmatrix3x3 cm) -{ - matrix3x3 m; - m.c0 = cvector3_re(cm.c0); - m.c1 = cvector3_re(cm.c1); - m.c2 = cvector3_re(cm.c2); - return m; -} - -matrix3x3 cmatrix3x3_im(cmatrix3x3 cm) -{ - matrix3x3 m; - m.c0 = cvector3_im(cm.c0); - m.c1 = cvector3_im(cm.c1); - m.c2 = cvector3_im(cm.c2); - return m; -} - -cmatrix3x3 make_cmatrix3x3(matrix3x3 mr, matrix3x3 mi) -{ - cmatrix3x3 cm; - cm.c0 = make_cvector3(mr.c0, mi.c0); - cm.c1 = make_cvector3(mr.c1, mi.c1); - cm.c2 = make_cvector3(mr.c2, mi.c2); - return cm; -} - -cmatrix3x3 make_hermitian_cmatrix3x3(number m00, number m11, number m22, - cnumber m01, cnumber m02, cnumber m12) -{ - cmatrix3x3 cm; - cm.c0.x = make_cnumber(m00, 0); - cm.c1.y = make_cnumber(m11, 0); - cm.c2.z = make_cnumber(m22, 0); - cm.c1.x = m01; cm.c0.y = cnumber_conj(m01); - cm.c2.x = m02; cm.c0.z = cnumber_conj(m02); - cm.c2.y = m12; cm.c1.z = cnumber_conj(m12); - return cm; -} - -int cmatrix3x3_equal(cmatrix3x3 m1, cmatrix3x3 m2) -{ - return (matrix3x3_equal(cmatrix3x3_re(m1), cmatrix3x3_re(m2)) && - matrix3x3_equal(cmatrix3x3_im(m1), cmatrix3x3_im(m2))); +cnumber make_cnumber(number r, number i) { + cnumber c; + c.re = r; + c.im = i; + return c; +} + +cnumber cnumber_conj(cnumber c) { return make_cnumber(c.re, -c.im); } + +int cnumber_equal(cnumber c1, cnumber c2) { return (c1.re == c2.re && c1.im == c2.im); } + +vector3 cvector3_re(cvector3 cv) { + vector3 v; + v.x = cv.x.re; + v.y = cv.y.re; + v.z = cv.z.re; + return v; +} + +vector3 cvector3_im(cvector3 cv) { + vector3 v; + v.x = cv.x.im; + v.y = cv.y.im; + v.z = cv.z.im; + return v; +} + +cvector3 make_cvector3(vector3 vr, vector3 vi) { + cvector3 cv; + cv.x = make_cnumber(vr.x, vi.x); + cv.y = make_cnumber(vr.y, vi.y); + cv.z = make_cnumber(vr.z, vi.z); + return cv; +} + +int cvector3_equal(cvector3 v1, cvector3 v2) { + return (vector3_equal(cvector3_re(v1), cvector3_re(v2)) && + vector3_equal(cvector3_im(v1), cvector3_im(v2))); +} + +matrix3x3 cmatrix3x3_re(cmatrix3x3 cm) { + matrix3x3 m; + m.c0 = cvector3_re(cm.c0); + m.c1 = cvector3_re(cm.c1); + m.c2 = cvector3_re(cm.c2); + return m; +} + +matrix3x3 cmatrix3x3_im(cmatrix3x3 cm) { + matrix3x3 m; + m.c0 = cvector3_im(cm.c0); + m.c1 = cvector3_im(cm.c1); + m.c2 = cvector3_im(cm.c2); + return m; +} + +cmatrix3x3 make_cmatrix3x3(matrix3x3 mr, matrix3x3 mi) { + cmatrix3x3 cm; + cm.c0 = make_cvector3(mr.c0, mi.c0); + cm.c1 = make_cvector3(mr.c1, mi.c1); + cm.c2 = make_cvector3(mr.c2, mi.c2); + return cm; +} + +cmatrix3x3 make_hermitian_cmatrix3x3(number m00, number m11, number m22, cnumber m01, cnumber m02, + cnumber m12) { + cmatrix3x3 cm; + cm.c0.x = make_cnumber(m00, 0); + cm.c1.y = make_cnumber(m11, 0); + cm.c2.z = make_cnumber(m22, 0); + cm.c1.x = m01; + cm.c0.y = cnumber_conj(m01); + cm.c2.x = m02; + cm.c0.z = cnumber_conj(m02); + cm.c2.y = m12; + cm.c1.z = cnumber_conj(m12); + return cm; +} + +int cmatrix3x3_equal(cmatrix3x3 m1, cmatrix3x3 m2) { + return (matrix3x3_equal(cmatrix3x3_re(m1), cmatrix3x3_re(m2)) && + matrix3x3_equal(cmatrix3x3_im(m1), cmatrix3x3_im(m2))); } diff -Nru libctl-4.4.0/src/ctl-math.h libctl-4.5.0/src/ctl-math.h --- libctl-4.4.0/src/ctl-math.h 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/src/ctl-math.h 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -19,48 +19,58 @@ * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ - /* just the non-Guile-based vector/matrix math routines in - libctl, for use in libctlgeom */ +/* just the non-Guile-based vector/matrix math routines in + libctl, for use in libctlgeom */ #ifndef CTL_MATH_H #define CTL_MATH_H #ifdef __cplusplus extern "C" { -#endif /* __cplusplus */ +#endif /* __cplusplus */ /**************************************************************************/ - /* Basic types: */ +/* Basic types: */ typedef int integer; typedef double number; -typedef struct { number re, im; } cnumber; /* complex numbers! */ +typedef struct { + number re, im; +} cnumber; /* complex numbers! */ typedef short boolean; typedef char *string; - /* define vector3 as a structure, not an array, so that it can - be a function return value and so that simple assignment works. */ -typedef struct { number x,y,z; } vector3; - - /* similarly for matrix3x3 */ -typedef struct { vector3 c0, c1, c2; /* the columns */ } matrix3x3; +/* define vector3 as a structure, not an array, so that it can + be a function return value and so that simple assignment works. */ +typedef struct { + number x, y, z; +} vector3; + +/* similarly for matrix3x3 */ +typedef struct { + vector3 c0, c1, c2; /* the columns */ +} matrix3x3; /* define complex equivalents: */ -typedef struct { cnumber x,y,z; } cvector3; -typedef struct { cvector3 c0, c1, c2; /* the columns */ } cmatrix3x3; +typedef struct { + cnumber x, y, z; +} cvector3; +typedef struct { + cvector3 c0, c1, c2; /* the columns */ +} cmatrix3x3; /**************************************************************************/ - /* vector3 and matrix3x3 utilities: */ +/* vector3 and matrix3x3 utilities: */ -extern number vector3_dot(vector3 v1,vector3 v2); +extern number vector3_dot(vector3 v1, vector3 v2); extern number vector3_norm(vector3 v); extern vector3 vector3_scale(number s, vector3 v); extern vector3 unit_vector3(vector3 v); -extern vector3 vector3_cross(vector3 v1,vector3 v2); -extern vector3 vector3_plus(vector3 v1,vector3 v2); -extern vector3 vector3_minus(vector3 v1,vector3 v2); +extern vector3 vector3_cross(vector3 v1, vector3 v2); +extern vector3 vector3_plus(vector3 v1, vector3 v2); +extern vector3 vector3_minus(vector3 v1, vector3 v2); extern int vector3_equal(vector3 v1, vector3 v2); extern vector3 matrix3x3_vector3_mult(matrix3x3 m, vector3 v); @@ -77,7 +87,7 @@ /**************************************************************************/ - /* complex number utilities */ +/* complex number utilities */ extern cnumber make_cnumber(number r, number i); extern cnumber cnumber_conj(cnumber c); @@ -93,26 +103,24 @@ extern matrix3x3 cmatrix3x3_re(cmatrix3x3 cm); extern matrix3x3 cmatrix3x3_im(cmatrix3x3 cm); extern cmatrix3x3 make_cmatrix3x3(matrix3x3 mr, matrix3x3 mi); -cmatrix3x3 make_hermitian_cmatrix3x3(number m00, number m11, number m22, - cnumber m01, cnumber m02, cnumber m12); +cmatrix3x3 make_hermitian_cmatrix3x3(number m00, number m11, number m22, cnumber m01, cnumber m02, + cnumber m12); extern int cmatrix3x3_equal(cmatrix3x3 m1, cmatrix3x3 m2); /**************************************************************************/ - /* multi-dimensional integration routines */ +/* multi-dimensional integration routines */ -typedef number (*multivar_func) (integer, number *, void *); +typedef number (*multivar_func)(integer, number *, void *); -extern number adaptive_integration(multivar_func f, number *xmin, number *xmax, - integer n, void *fdata, - number abstol, number reltol, - integer maxnfe, - number *esterr, integer *errflag); +extern number adaptive_integration(multivar_func f, number *xmin, number *xmax, integer n, + void *fdata, number abstol, number reltol, integer maxnfe, + number *esterr, integer *errflag); /**************************************************************************/ #ifdef __cplusplus - } /* extern "C" */ -#endif /* __cplusplus */ +} /* extern "C" */ +#endif /* __cplusplus */ #endif /* CTL_MATH_H */ diff -Nru libctl-4.4.0/src/integrator.c libctl-4.5.0/src/integrator.c --- libctl-4.4.0/src/integrator.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/src/integrator.c 2020-02-19 18:34:33.000000000 +0000 @@ -51,7 +51,7 @@ */ -typedef double (*integrand) (unsigned ndim, const double *x, void *); +typedef double (*integrand)(unsigned ndim, const double *x, void *); /* Integrate the function f from xmin[dim] to xmax[dim], with at most maxEval function evaluations (0 for no limit), until the given @@ -59,119 +59,102 @@ and err returns the estimate for the absolute error in val. The return value of the function is 0 on success and non-zero if there was an error. */ -static int adapt_integrate(integrand f, void *fdata, - unsigned dim, const double *xmin, const double *xmax, - unsigned maxEval, - double reqAbsError, double reqRelError, - double *val, double *err); +static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, + const double *xmax, unsigned maxEval, double reqAbsError, + double reqRelError, double *val, double *err); /***************************************************************************/ /* Basic datatypes */ typedef struct { - double val, err; + double val, err; } esterr; -static double relError(esterr ee) -{ - return (ee.val == 0.0 ? HUGE_VAL : fabs(ee.err / ee.val)); -} +static double relError(esterr ee) { return (ee.val == 0.0 ? HUGE_VAL : fabs(ee.err / ee.val)); } typedef struct { - unsigned dim; - double *data; /* length 2*dim = center followed by half-widths */ - double vol; /* cache volume = product of widths */ + unsigned dim; + double *data; /* length 2*dim = center followed by half-widths */ + double vol; /* cache volume = product of widths */ } hypercube; -static double compute_vol(const hypercube *h) -{ - unsigned i; - double vol = 1; - for (i = 0; i < h->dim; ++i) - vol *= 2 * h->data[i + h->dim]; - return vol; -} - -static hypercube make_hypercube(unsigned dim, const double *center, const double *halfwidth) -{ - unsigned i; - hypercube h; - h.dim = dim; - h.data = (double *) malloc(sizeof(double) * dim * 2); - for (i = 0; i < dim; ++i) { - h.data[i] = center[i]; - h.data[i + dim] = halfwidth[i]; - } - h.vol = compute_vol(&h); - return h; -} - -static hypercube make_hypercube_range(unsigned dim, const double *xmin, const double *xmax) -{ - hypercube h = make_hypercube(dim, xmin, xmax); - unsigned i; - for (i = 0; i < dim; ++i) { - h.data[i] = 0.5 * (xmin[i] + xmax[i]); - h.data[i + dim] = 0.5 * (xmax[i] - xmin[i]); - } - h.vol = compute_vol(&h); - return h; -} - -static void destroy_hypercube(hypercube *h) -{ - free(h->data); - h->dim = 0; +static double compute_vol(const hypercube *h) { + unsigned i; + double vol = 1; + for (i = 0; i < h->dim; ++i) + vol *= 2 * h->data[i + h->dim]; + return vol; +} + +static hypercube make_hypercube(unsigned dim, const double *center, const double *halfwidth) { + unsigned i; + hypercube h; + h.dim = dim; + h.data = (double *)malloc(sizeof(double) * dim * 2); + for (i = 0; i < dim; ++i) { + h.data[i] = center[i]; + h.data[i + dim] = halfwidth[i]; + } + h.vol = compute_vol(&h); + return h; +} + +static hypercube make_hypercube_range(unsigned dim, const double *xmin, const double *xmax) { + hypercube h = make_hypercube(dim, xmin, xmax); + unsigned i; + for (i = 0; i < dim; ++i) { + h.data[i] = 0.5 * (xmin[i] + xmax[i]); + h.data[i + dim] = 0.5 * (xmax[i] - xmin[i]); + } + h.vol = compute_vol(&h); + return h; +} + +static void destroy_hypercube(hypercube *h) { + free(h->data); + h->dim = 0; } typedef struct { - hypercube h; - esterr ee; - unsigned splitDim; + hypercube h; + esterr ee; + unsigned splitDim; } region; -static region make_region(const hypercube *h) -{ - region R; - R.h = make_hypercube(h->dim, h->data, h->data + h->dim); - R.splitDim = 0; - return R; -} - -static void destroy_region(region *R) -{ - destroy_hypercube(&R->h); -} - -static void cut_region(region *R, region *R2) -{ - unsigned d = R->splitDim, dim = R->h.dim; - *R2 = *R; - R->h.data[d + dim] *= 0.5; - R->h.vol *= 0.5; - R2->h = make_hypercube(dim, R->h.data, R->h.data + dim); - R->h.data[d] -= R->h.data[d + dim]; - R2->h.data[d] += R->h.data[d + dim]; +static region make_region(const hypercube *h) { + region R; + R.h = make_hypercube(h->dim, h->data, h->data + h->dim); + R.splitDim = 0; + return R; +} + +static void destroy_region(region *R) { destroy_hypercube(&R->h); } + +static void cut_region(region *R, region *R2) { + unsigned d = R->splitDim, dim = R->h.dim; + *R2 = *R; + R->h.data[d + dim] *= 0.5; + R->h.vol *= 0.5; + R2->h = make_hypercube(dim, R->h.data, R->h.data + dim); + R->h.data[d] -= R->h.data[d + dim]; + R2->h.data[d] += R->h.data[d + dim]; } typedef struct rule_s { - unsigned dim; /* the dimensionality */ - unsigned num_points; /* number of evaluation points */ - unsigned (*evalError)(struct rule_s *r, integrand f, void *fdata, - const hypercube *h, esterr *ee); - void (*destroy)(struct rule_s *r); + unsigned dim; /* the dimensionality */ + unsigned num_points; /* number of evaluation points */ + unsigned (*evalError)(struct rule_s *r, integrand f, void *fdata, const hypercube *h, esterr *ee); + void (*destroy)(struct rule_s *r); } rule; -static void destroy_rule(rule *r) -{ - if (r->destroy) r->destroy(r); - free(r); +static void destroy_rule(rule *r) { + if (r->destroy) r->destroy(r); + free(r); } -static region eval_region(region R, integrand f, void *fdata, rule *r) -{ - R.splitDim = r->evalError(r, f, fdata, &R.h, &R.ee); - return R; +static region eval_region(region R, integrand f, void *fdata, rule *r) { + R.splitDim = r->evalError(r, f, fdata, &R.h, &R.ee); + return R; } /***************************************************************************/ @@ -182,43 +165,34 @@ /* ls0 returns the least-significant 0 bit of n (e.g. it returns 0 if the LSB is 0, it returns 1 if the 2 LSBs are 01, etcetera). */ -#if (defined(__GNUC__) || defined(__ICC)) && (defined(__i386__) || defined (__x86_64__)) +#if (defined(__GNUC__) || defined(__ICC)) && (defined(__i386__) || defined(__x86_64__)) /* use x86 bit-scan instruction, based on count_trailing_zeros() macro in GNU GMP's longlong.h. */ -static unsigned ls0(unsigned n) -{ - unsigned count; - n = ~n; - __asm__("bsfl %1,%0": "=r"(count):"rm"(n)); - return count; +static unsigned ls0(unsigned n) { + unsigned count; + n = ~n; + __asm__("bsfl %1,%0" : "=r"(count) : "rm"(n)); + return count; } #else -static unsigned ls0(unsigned n) -{ - const unsigned bits[256] = { - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, - 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 8, - }; - unsigned bit = 0; - while ((n & 0xff) == 0xff) { - n >>= 8; - bit += 8; - } - return bit + bits[n & 0xff]; +static unsigned ls0(unsigned n) { + const unsigned bits[256] = { + 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, + 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, + 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, + 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, + 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, + 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, + 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, + 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, + 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 8, + }; + unsigned bit = 0; + while ((n & 0xff) == 0xff) { + n >>= 8; + bit += 8; + } + return bit + bits[n & 0xff]; } #endif @@ -228,101 +202,101 @@ * A Gray-code ordering is used to minimize the number of coordinate updates * in p. */ -static double evalR_Rfs(integrand f, void *fdata, unsigned dim, double *p, const double *c, const double *r) -{ - double sum = 0; - unsigned i; - unsigned signs = 0; /* 0/1 bit = +/- for corresponding element of r[] */ - - /* We start with the point where r is ADDed in every coordinate - (this implies signs=0). */ - for (i = 0; i < dim; ++i) - p[i] = c[i] + r[i]; - - /* Loop through the points in Gray-code ordering */ - for (i = 0;; ++i) { - unsigned mask, d; - - sum += f(dim, p, fdata); - - d = ls0(i); /* which coordinate to flip */ - if (d >= dim) - break; - - /* flip the d-th bit and add/subtract r[d] */ - mask = 1U << d; - signs ^= mask; - p[d] = (signs & mask) ? c[d] - r[d] : c[d] + r[d]; - } - return sum; -} - -static double evalRR0_0fs(integrand f, void *fdata, unsigned dim, double *p, const double *c, const double *r) -{ - unsigned i, j; - double sum = 0; - - for (i = 0; i < dim - 1; ++i) { - p[i] = c[i] - r[i]; - for (j = i + 1; j < dim; ++j) { - p[j] = c[j] - r[j]; - sum += f(dim, p, fdata); - p[i] = c[i] + r[i]; - sum += f(dim, p, fdata); - p[j] = c[j] + r[j]; - sum += f(dim, p, fdata); - p[i] = c[i] - r[i]; - sum += f(dim, p, fdata); - - p[j] = c[j]; /* Done with j -> Restore p[j] */ - } - p[i] = c[i]; /* Done with i -> Restore p[i] */ - } - return sum; -} - -static unsigned evalR0_0fs4d(integrand f, void *fdata, unsigned dim, double *p, const double *c, double *sum0_, const double *r1, double *sum1_, const double *r2, double *sum2_) -{ - double maxdiff = 0; - unsigned i, dimDiffMax = 0; - double sum0, sum1 = 0, sum2 = 0; /* copies for aliasing, performance */ - - double ratio = r1[0] / r2[0]; - - ratio *= ratio; - sum0 = f(dim, p, fdata); - - for (i = 0; i < dim; i++) { - double f1a, f1b, f2a, f2b, diff; - - p[i] = c[i] - r1[i]; - sum1 += (f1a = f(dim, p, fdata)); - p[i] = c[i] + r1[i]; - sum1 += (f1b = f(dim, p, fdata)); - p[i] = c[i] - r2[i]; - sum2 += (f2a = f(dim, p, fdata)); - p[i] = c[i] + r2[i]; - sum2 += (f2b = f(dim, p, fdata)); - p[i] = c[i]; - - diff = fabs(f1a + f1b - 2 * sum0 - ratio * (f2a + f2b - 2 * sum0)); - - if (diff > maxdiff) { - maxdiff = diff; - dimDiffMax = i; - } - } - - *sum0_ += sum0; - *sum1_ += sum1; - *sum2_ += sum2; +static double evalR_Rfs(integrand f, void *fdata, unsigned dim, double *p, const double *c, + const double *r) { + double sum = 0; + unsigned i; + unsigned signs = 0; /* 0/1 bit = +/- for corresponding element of r[] */ + + /* We start with the point where r is ADDed in every coordinate + (this implies signs=0). */ + for (i = 0; i < dim; ++i) + p[i] = c[i] + r[i]; + + /* Loop through the points in Gray-code ordering */ + for (i = 0;; ++i) { + unsigned mask, d; + + sum += f(dim, p, fdata); + + d = ls0(i); /* which coordinate to flip */ + if (d >= dim) break; + + /* flip the d-th bit and add/subtract r[d] */ + mask = 1U << d; + signs ^= mask; + p[d] = (signs & mask) ? c[d] - r[d] : c[d] + r[d]; + } + return sum; +} + +static double evalRR0_0fs(integrand f, void *fdata, unsigned dim, double *p, const double *c, + const double *r) { + unsigned i, j; + double sum = 0; + + for (i = 0; i < dim - 1; ++i) { + p[i] = c[i] - r[i]; + for (j = i + 1; j < dim; ++j) { + p[j] = c[j] - r[j]; + sum += f(dim, p, fdata); + p[i] = c[i] + r[i]; + sum += f(dim, p, fdata); + p[j] = c[j] + r[j]; + sum += f(dim, p, fdata); + p[i] = c[i] - r[i]; + sum += f(dim, p, fdata); + + p[j] = c[j]; /* Done with j -> Restore p[j] */ + } + p[i] = c[i]; /* Done with i -> Restore p[i] */ + } + return sum; +} + +static unsigned evalR0_0fs4d(integrand f, void *fdata, unsigned dim, double *p, const double *c, + double *sum0_, const double *r1, double *sum1_, const double *r2, + double *sum2_) { + double maxdiff = 0; + unsigned i, dimDiffMax = 0; + double sum0, sum1 = 0, sum2 = 0; /* copies for aliasing, performance */ + + double ratio = r1[0] / r2[0]; + + ratio *= ratio; + sum0 = f(dim, p, fdata); + + for (i = 0; i < dim; i++) { + double f1a, f1b, f2a, f2b, diff; + + p[i] = c[i] - r1[i]; + sum1 += (f1a = f(dim, p, fdata)); + p[i] = c[i] + r1[i]; + sum1 += (f1b = f(dim, p, fdata)); + p[i] = c[i] - r2[i]; + sum2 += (f2a = f(dim, p, fdata)); + p[i] = c[i] + r2[i]; + sum2 += (f2b = f(dim, p, fdata)); + p[i] = c[i]; + + diff = fabs(f1a + f1b - 2 * sum0 - ratio * (f2a + f2b - 2 * sum0)); + + if (diff > maxdiff) { + maxdiff = diff; + dimDiffMax = i; + } + } + + *sum0_ += sum0; + *sum1_ += sum1; + *sum2_ += sum2; - return dimDiffMax; + return dimDiffMax; } #define num0_0(dim) (1U) #define numR0_0fs(dim) (2 * (dim)) -#define numRR0_0fs(dim) (2 * (dim) * (dim-1)) +#define numRR0_0fs(dim) (2 * (dim) * (dim - 1)) #define numR_Rfs(dim) (1U << (dim)) /***************************************************************************/ @@ -336,224 +310,214 @@ */ typedef struct { - rule parent; + rule parent; - /* temporary arrays of length dim */ - double *widthLambda, *widthLambda2, *p; + /* temporary arrays of length dim */ + double *widthLambda, *widthLambda2, *p; - /* dimension-dependent constants */ - double weight1, weight3, weight5; - double weightE1, weightE3; + /* dimension-dependent constants */ + double weight1, weight3, weight5; + double weightE1, weightE3; } rule75genzmalik; #define real(x) ((double)(x)) #define to_int(n) ((int)(n)) -static int isqr(int x) -{ - return x * x; -} +static int isqr(int x) { return x * x; } -static void destroy_rule75genzmalik(rule *r_) -{ - rule75genzmalik *r = (rule75genzmalik *) r_; - free(r->p); +static void destroy_rule75genzmalik(rule *r_) { + rule75genzmalik *r = (rule75genzmalik *)r_; + free(r->p); } -static unsigned rule75genzmalik_evalError(rule *r_, integrand f, void *fdata, const hypercube *h, esterr *ee) -{ - /* lambda2 = sqrt(9/70), lambda4 = sqrt(9/10), lambda5 = sqrt(9/19) */ - const double lambda2 = 0.3585685828003180919906451539079374954541; - const double lambda4 = 0.9486832980505137995996680633298155601160; - const double lambda5 = 0.6882472016116852977216287342936235251269; - const double weight2 = 980. / 6561.; - const double weight4 = 200. / 19683.; - const double weightE2 = 245. / 486.; - const double weightE4 = 25. / 729.; +static unsigned rule75genzmalik_evalError(rule *r_, integrand f, void *fdata, const hypercube *h, + esterr *ee) { + /* lambda2 = sqrt(9/70), lambda4 = sqrt(9/10), lambda5 = sqrt(9/19) */ + const double lambda2 = 0.3585685828003180919906451539079374954541; + const double lambda4 = 0.9486832980505137995996680633298155601160; + const double lambda5 = 0.6882472016116852977216287342936235251269; + const double weight2 = 980. / 6561.; + const double weight4 = 200. / 19683.; + const double weightE2 = 245. / 486.; + const double weightE4 = 25. / 729.; - rule75genzmalik *r = (rule75genzmalik *) r_; - unsigned i, dimDiffMax, dim = r_->dim; - double sum1 = 0.0, sum2 = 0.0, sum3 = 0.0, sum4, sum5, result, res5th; - const double *center = h->data; - const double *halfwidth = h->data + dim; + rule75genzmalik *r = (rule75genzmalik *)r_; + unsigned i, dimDiffMax, dim = r_->dim; + double sum1 = 0.0, sum2 = 0.0, sum3 = 0.0, sum4, sum5, result, res5th; + const double *center = h->data; + const double *halfwidth = h->data + dim; - for (i = 0; i < dim; ++i) - r->p[i] = center[i]; + for (i = 0; i < dim; ++i) + r->p[i] = center[i]; - for (i = 0; i < dim; ++i) - r->widthLambda2[i] = halfwidth[i] * lambda2; - for (i = 0; i < dim; ++i) - r->widthLambda[i] = halfwidth[i] * lambda4; + for (i = 0; i < dim; ++i) + r->widthLambda2[i] = halfwidth[i] * lambda2; + for (i = 0; i < dim; ++i) + r->widthLambda[i] = halfwidth[i] * lambda4; - /* Evaluate function in the center, in f(lambda2,0,...,0) and - f(lambda3=lambda4, 0,...,0). Estimate dimension with largest error */ - dimDiffMax = evalR0_0fs4d(f, fdata, dim, r->p, center, &sum1, r->widthLambda2, &sum2, r->widthLambda, &sum3); + /* Evaluate function in the center, in f(lambda2,0,...,0) and + f(lambda3=lambda4, 0,...,0). Estimate dimension with largest error */ + dimDiffMax = evalR0_0fs4d(f, fdata, dim, r->p, center, &sum1, r->widthLambda2, &sum2, + r->widthLambda, &sum3); - /* Calculate sum4 for f(lambda4, lambda4, 0, ...,0) */ - sum4 = evalRR0_0fs(f, fdata, dim, r->p, center, r->widthLambda); + /* Calculate sum4 for f(lambda4, lambda4, 0, ...,0) */ + sum4 = evalRR0_0fs(f, fdata, dim, r->p, center, r->widthLambda); - /* Calculate sum5 for f(lambda5, lambda5, ..., lambda5) */ - for (i = 0; i < dim; ++i) - r->widthLambda[i] = halfwidth[i] * lambda5; - sum5 = evalR_Rfs(f, fdata, dim, r->p, center, r->widthLambda); + /* Calculate sum5 for f(lambda5, lambda5, ..., lambda5) */ + for (i = 0; i < dim; ++i) + r->widthLambda[i] = halfwidth[i] * lambda5; + sum5 = evalR_Rfs(f, fdata, dim, r->p, center, r->widthLambda); - /* Calculate fifth and seventh order results */ + /* Calculate fifth and seventh order results */ - result = h->vol * (r->weight1 * sum1 + weight2 * sum2 + r->weight3 * sum3 + weight4 * sum4 + r->weight5 * sum5); - res5th = h->vol * (r->weightE1 * sum1 + weightE2 * sum2 + r->weightE3 * sum3 + weightE4 * sum4); + result = h->vol * (r->weight1 * sum1 + weight2 * sum2 + r->weight3 * sum3 + weight4 * sum4 + + r->weight5 * sum5); + res5th = h->vol * (r->weightE1 * sum1 + weightE2 * sum2 + r->weightE3 * sum3 + weightE4 * sum4); - ee->val = result; - ee->err = fabs(res5th - result); + ee->val = result; + ee->err = fabs(res5th - result); - return dimDiffMax; + return dimDiffMax; } -static rule *make_rule75genzmalik(unsigned dim) -{ - rule75genzmalik *r; +static rule *make_rule75genzmalik(unsigned dim) { + rule75genzmalik *r; - if (dim < 2) return 0; /* this rule does not support 1d integrals */ + if (dim < 2) return 0; /* this rule does not support 1d integrals */ - /* Because of the use of a bit-field in evalR_Rfs, we are limited - to be < 32 dimensions (or however many bits are in unsigned). - This is not a practical limitation...long before you reach - 32 dimensions, the Genz-Malik cubature becomes excruciatingly - slow and is superseded by other methods (e.g. Monte-Carlo). */ - if (dim >= sizeof(unsigned) * 8) return 0; + /* Because of the use of a bit-field in evalR_Rfs, we are limited + to be < 32 dimensions (or however many bits are in unsigned). + This is not a practical limitation...long before you reach + 32 dimensions, the Genz-Malik cubature becomes excruciatingly + slow and is superseded by other methods (e.g. Monte-Carlo). */ + if (dim >= sizeof(unsigned) * 8) return 0; - r = (rule75genzmalik *) malloc(sizeof(rule75genzmalik)); - r->parent.dim = dim; + r = (rule75genzmalik *)malloc(sizeof(rule75genzmalik)); + r->parent.dim = dim; - r->weight1 = (real(12824 - 9120 * to_int(dim) + 400 * isqr(to_int(dim))) - / real(19683)); - r->weight3 = real(1820 - 400 * to_int(dim)) / real(19683); - r->weight5 = real(6859) / real(19683) / real(1U << dim); - r->weightE1 = (real(729 - 950 * to_int(dim) + 50 * isqr(to_int(dim))) - / real(729)); - r->weightE3 = real(265 - 100 * to_int(dim)) / real(1458); + r->weight1 = (real(12824 - 9120 * to_int(dim) + 400 * isqr(to_int(dim))) / real(19683)); + r->weight3 = real(1820 - 400 * to_int(dim)) / real(19683); + r->weight5 = real(6859) / real(19683) / real(1U << dim); + r->weightE1 = (real(729 - 950 * to_int(dim) + 50 * isqr(to_int(dim))) / real(729)); + r->weightE3 = real(265 - 100 * to_int(dim)) / real(1458); - r->p = (double *) malloc(sizeof(double) * dim * 3); - r->widthLambda = r->p + dim; - r->widthLambda2 = r->p + 2 * dim; + r->p = (double *)malloc(sizeof(double) * dim * 3); + r->widthLambda = r->p + dim; + r->widthLambda2 = r->p + 2 * dim; - r->parent.num_points = num0_0(dim) + 2 * numR0_0fs(dim) - + numRR0_0fs(dim) + numR_Rfs(dim); + r->parent.num_points = num0_0(dim) + 2 * numR0_0fs(dim) + numRR0_0fs(dim) + numR_Rfs(dim); - r->parent.evalError = rule75genzmalik_evalError; - r->parent.destroy = destroy_rule75genzmalik; + r->parent.evalError = rule75genzmalik_evalError; + r->parent.destroy = destroy_rule75genzmalik; - return (rule *) r; + return (rule *)r; } /***************************************************************************/ /* 1d 15-point Gaussian quadrature rule, based on qk15.c and qk.c in GNU GSL (which in turn is based on QUADPACK). */ -static unsigned rule15gauss_evalError(rule *r, integrand f, void *fdata, - const hypercube *h, esterr *ee) -{ - /* Gauss quadrature weights and kronrod quadrature abscissae and - weights as evaluated with 80 decimal digit arithmetic by - L. W. Fullerton, Bell Labs, Nov. 1981. */ - const unsigned n = 8; - const double xgk[8] = { /* abscissae of the 15-point kronrod rule */ - 0.991455371120812639206854697526329, - 0.949107912342758524526189684047851, - 0.864864423359769072789712788640926, - 0.741531185599394439863864773280788, - 0.586087235467691130294144838258730, - 0.405845151377397166906606412076961, - 0.207784955007898467600689403773245, - 0.000000000000000000000000000000000 - /* xgk[1], xgk[3], ... abscissae of the 7-point gauss rule. - xgk[0], xgk[2], ... to optimally extend the 7-point gauss rule */ - }; - static const double wg[4] = { /* weights of the 7-point gauss rule */ - 0.129484966168869693270611432679082, - 0.279705391489276667901467771423780, - 0.381830050505118944950369775488975, - 0.417959183673469387755102040816327 - }; - static const double wgk[8] = { /* weights of the 15-point kronrod rule */ - 0.022935322010529224963732008058970, - 0.063092092629978553290700663189204, - 0.104790010322250183839876322541518, - 0.140653259715525918745189590510238, - 0.169004726639267902826583426598550, - 0.190350578064785409913256402421014, - 0.204432940075298892414161999234649, - 0.209482141084727828012999174891714 - }; - - const double center = h->data[0]; - const double halfwidth = h->data[1]; - double fv1[7], fv2[7]; - const double f_center = f(1, ¢er, fdata); - double result_gauss = f_center * wg[n/2 - 1]; - double result_kronrod = f_center * wgk[n - 1]; - double result_abs = fabs(result_kronrod); - double result_asc, mean, err; - unsigned j; - - (void) r; /* unused */ - - for (j = 0; j < (n - 1) / 2; ++j) { - int j2 = 2*j + 1; - double x, f1, f2, fsum, w = halfwidth * xgk[j2]; - x = center - w; fv1[j2] = f1 = f(1, &x, fdata); - x = center + w; fv2[j2] = f2 = f(1, &x, fdata); - fsum = f1 + f2; - result_gauss += wg[j] * fsum; - result_kronrod += wgk[j2] * fsum; - result_abs += wgk[j2] * (fabs(f1) + fabs(f2)); - } - - for (j = 0; j < n/2; ++j) { - int j2 = 2*j; - double x, f1, f2, w = halfwidth * xgk[j2]; - x = center - w; fv1[j2] = f1 = f(1, &x, fdata); - x = center + w; fv2[j2] = f2 = f(1, &x, fdata); - result_kronrod += wgk[j2] * (f1 + f2); - result_abs += wgk[j2] * (fabs(f1) + fabs(f2)); - } - - ee->val = result_kronrod * halfwidth; - - /* compute error estimate: */ - mean = result_kronrod * 0.5; - result_asc = wgk[n - 1] * fabs(f_center - mean); - for (j = 0; j < n - 1; ++j) - result_asc += wgk[j] * (fabs(fv1[j]-mean) + fabs(fv2[j]-mean)); - err = fabs(result_kronrod - result_gauss) * halfwidth; - result_abs *= halfwidth; - result_asc *= halfwidth; - if (result_asc != 0 && err != 0) { - double scale = pow((200 * err / result_asc), 1.5); - if (scale < 1) - err = result_asc * scale; - else - err = result_asc; - } - if (result_abs > DBL_MIN / (50 * DBL_EPSILON)) { - double min_err = 50 * DBL_EPSILON * result_abs; - if (min_err > err) - err = min_err; - } - ee->err = err; - - return 0; /* no choice but to divide 0th dimension */ -} - -static rule *make_rule15gauss(unsigned dim) -{ - rule *r; - if (dim != 1) return 0; /* this rule is only for 1d integrals */ - r = (rule *) malloc(sizeof(rule)); - r->dim = dim; - r->num_points = 15; - r->evalError = rule15gauss_evalError; - r->destroy = 0; - return r; +static unsigned rule15gauss_evalError(rule *r, integrand f, void *fdata, const hypercube *h, + esterr *ee) { + /* Gauss quadrature weights and kronrod quadrature abscissae and + weights as evaluated with 80 decimal digit arithmetic by + L. W. Fullerton, Bell Labs, Nov. 1981. */ + const unsigned n = 8; + const double xgk[8] = { + /* abscissae of the 15-point kronrod rule */ + 0.991455371120812639206854697526329, + 0.949107912342758524526189684047851, + 0.864864423359769072789712788640926, + 0.741531185599394439863864773280788, + 0.586087235467691130294144838258730, + 0.405845151377397166906606412076961, + 0.207784955007898467600689403773245, + 0.000000000000000000000000000000000 + /* xgk[1], xgk[3], ... abscissae of the 7-point gauss rule. + xgk[0], xgk[2], ... to optimally extend the 7-point gauss rule */ + }; + static const double wg[4] = { + /* weights of the 7-point gauss rule */ + 0.129484966168869693270611432679082, 0.279705391489276667901467771423780, + 0.381830050505118944950369775488975, 0.417959183673469387755102040816327}; + static const double wgk[8] = { + /* weights of the 15-point kronrod rule */ + 0.022935322010529224963732008058970, 0.063092092629978553290700663189204, + 0.104790010322250183839876322541518, 0.140653259715525918745189590510238, + 0.169004726639267902826583426598550, 0.190350578064785409913256402421014, + 0.204432940075298892414161999234649, 0.209482141084727828012999174891714}; + + const double center = h->data[0]; + const double halfwidth = h->data[1]; + double fv1[7], fv2[7]; + const double f_center = f(1, ¢er, fdata); + double result_gauss = f_center * wg[n / 2 - 1]; + double result_kronrod = f_center * wgk[n - 1]; + double result_abs = fabs(result_kronrod); + double result_asc, mean, err; + unsigned j; + + (void)r; /* unused */ + + for (j = 0; j < (n - 1) / 2; ++j) { + int j2 = 2 * j + 1; + double x, f1, f2, fsum, w = halfwidth * xgk[j2]; + x = center - w; + fv1[j2] = f1 = f(1, &x, fdata); + x = center + w; + fv2[j2] = f2 = f(1, &x, fdata); + fsum = f1 + f2; + result_gauss += wg[j] * fsum; + result_kronrod += wgk[j2] * fsum; + result_abs += wgk[j2] * (fabs(f1) + fabs(f2)); + } + + for (j = 0; j < n / 2; ++j) { + int j2 = 2 * j; + double x, f1, f2, w = halfwidth * xgk[j2]; + x = center - w; + fv1[j2] = f1 = f(1, &x, fdata); + x = center + w; + fv2[j2] = f2 = f(1, &x, fdata); + result_kronrod += wgk[j2] * (f1 + f2); + result_abs += wgk[j2] * (fabs(f1) + fabs(f2)); + } + + ee->val = result_kronrod * halfwidth; + + /* compute error estimate: */ + mean = result_kronrod * 0.5; + result_asc = wgk[n - 1] * fabs(f_center - mean); + for (j = 0; j < n - 1; ++j) + result_asc += wgk[j] * (fabs(fv1[j] - mean) + fabs(fv2[j] - mean)); + err = fabs(result_kronrod - result_gauss) * halfwidth; + result_abs *= halfwidth; + result_asc *= halfwidth; + if (result_asc != 0 && err != 0) { + double scale = pow((200 * err / result_asc), 1.5); + if (scale < 1) + err = result_asc * scale; + else + err = result_asc; + } + if (result_abs > DBL_MIN / (50 * DBL_EPSILON)) { + double min_err = 50 * DBL_EPSILON * result_abs; + if (min_err > err) err = min_err; + } + ee->err = err; + + return 0; /* no choice but to divide 0th dimension */ +} + +static rule *make_rule15gauss(unsigned dim) { + rule *r; + if (dim != 1) return 0; /* this rule is only for 1d integrals */ + r = (rule *)malloc(sizeof(rule)); + r->dim = dim; + r->num_points = 15; + r->evalError = rule15gauss_evalError; + r->destroy = 0; + return r; } /***************************************************************************/ @@ -565,166 +529,156 @@ #define KEY(hi) ((hi).ee.err) typedef struct { - unsigned n, nalloc; - heap_item *items; - esterr ee; + unsigned n, nalloc; + heap_item *items; + esterr ee; } heap; -static void heap_resize(heap *h, unsigned nalloc) -{ - h->nalloc = nalloc; - h->items = (heap_item *) realloc(h->items, sizeof(heap_item) * nalloc); +static void heap_resize(heap *h, unsigned nalloc) { + h->nalloc = nalloc; + h->items = (heap_item *)realloc(h->items, sizeof(heap_item) * nalloc); } -static heap heap_alloc(unsigned nalloc) -{ - heap h; - h.n = 0; - h.nalloc = 0; - h.items = 0; - h.ee.val = h.ee.err = 0; - heap_resize(&h, nalloc); - return h; +static heap heap_alloc(unsigned nalloc) { + heap h; + h.n = 0; + h.nalloc = 0; + h.items = 0; + h.ee.val = h.ee.err = 0; + heap_resize(&h, nalloc); + return h; } /* note that heap_free does not deallocate anything referenced by the items */ -static void heap_free(heap *h) -{ - h->n = 0; - heap_resize(h, 0); -} - -static void heap_push(heap *h, heap_item hi) -{ - int insert; - - h->ee.val += hi.ee.val; - h->ee.err += hi.ee.err; - insert = h->n; - if (++(h->n) > h->nalloc) - heap_resize(h, h->n * 2); - - while (insert) { - int parent = (insert - 1) / 2; - if (KEY(hi) <= KEY(h->items[parent])) - break; - h->items[insert] = h->items[parent]; - insert = parent; - } - h->items[insert] = hi; -} - -static heap_item heap_pop(heap *h) -{ - heap_item ret; - int i, n, child; - - if (!(h->n)) { - fprintf(stderr, "attempted to pop an empty heap\n"); - exit(EXIT_FAILURE); - } - - ret = h->items[0]; - h->items[i = 0] = h->items[n = --(h->n)]; - while ((child = i * 2 + 1) < n) { - int largest; - heap_item swap; - - if (KEY(h->items[child]) <= KEY(h->items[i])) - largest = i; - else - largest = child; - if (++child < n && KEY(h->items[largest]) < KEY(h->items[child])) - largest = child; - if (largest == i) - break; - swap = h->items[i]; - h->items[i] = h->items[largest]; - h->items[i = largest] = swap; - } - - h->ee.val -= ret.ee.val; - h->ee.err -= ret.ee.err; - return ret; +static void heap_free(heap *h) { + h->n = 0; + heap_resize(h, 0); +} + +static void heap_push(heap *h, heap_item hi) { + int insert; + + h->ee.val += hi.ee.val; + h->ee.err += hi.ee.err; + insert = h->n; + if (++(h->n) > h->nalloc) heap_resize(h, h->n * 2); + + while (insert) { + int parent = (insert - 1) / 2; + if (KEY(hi) <= KEY(h->items[parent])) break; + h->items[insert] = h->items[parent]; + insert = parent; + } + h->items[insert] = hi; +} + +static heap_item heap_pop(heap *h) { + heap_item ret; + int i, n, child; + + if (!(h->n)) { + fprintf(stderr, "attempted to pop an empty heap\n"); + exit(EXIT_FAILURE); + } + + ret = h->items[0]; + h->items[i = 0] = h->items[n = --(h->n)]; + while ((child = i * 2 + 1) < n) { + int largest; + heap_item swap; + + if (KEY(h->items[child]) <= KEY(h->items[i])) + largest = i; + else + largest = child; + if (++child < n && KEY(h->items[largest]) < KEY(h->items[child])) largest = child; + if (largest == i) break; + swap = h->items[i]; + h->items[i] = h->items[largest]; + h->items[i = largest] = swap; + } + + h->ee.val -= ret.ee.val; + h->ee.err -= ret.ee.err; + return ret; } /***************************************************************************/ /* adaptive integration, analogous to adaptintegrator.cpp in HIntLib */ -static int ruleadapt_integrate(rule *r, integrand f, void *fdata, const hypercube *h, unsigned maxEval, double reqAbsError, double reqRelError, esterr *ee) -{ - unsigned maxIter; /* maximum number of adaptive subdivisions */ - heap regions; - unsigned i; - int status = -1; /* = ERROR */ - - if (maxEval) { - if (r->num_points > maxEval) - return status; /* ERROR */ - maxIter = (maxEval - r->num_points) / (2 * r->num_points); - } - else - maxIter = UINT_MAX; - - regions = heap_alloc(1); - - heap_push(®ions, eval_region(make_region(h), f, fdata, r)); - /* another possibility is to specify some non-adaptive subdivisions: - if (initialRegions != 1) - partition(h, initialRegions, EQUIDISTANT, ®ions, f,fdata, r); */ - - for (i = 0; i < maxIter; ++i) { - region R, R2; - if (regions.ee.err <= reqAbsError - || relError(regions.ee) <= reqRelError) { - status = 0; /* converged! */ - break; - } - R = heap_pop(®ions); /* get worst region */ - cut_region(&R, &R2); - heap_push(®ions, eval_region(R, f, fdata, r)); - heap_push(®ions, eval_region(R2, f, fdata, r)); - } - - ee->val = ee->err = 0; /* re-sum integral and errors */ - for (i = 0; i < regions.n; ++i) { - ee->val += regions.items[i].ee.val; - ee->err += regions.items[i].ee.err; - destroy_region(®ions.items[i]); - } - /* printf("regions.nalloc = %d\n", regions.nalloc); */ - heap_free(®ions); - - return status; -} - -static int adapt_integrate(integrand f, void *fdata, - unsigned dim, const double *xmin, const double *xmax, - unsigned maxEval, double reqAbsError, double reqRelError, - double *val, double *err) -{ - rule *r; - hypercube h; - esterr ee; - int status; - - if (dim == 0) { /* trivial integration */ - *val = f(0, xmin, fdata); - *err = 0; - return 0; - } - r = dim == 1 ? make_rule15gauss(dim) : make_rule75genzmalik(dim); - if (!r) { *val = 0; *err = HUGE_VAL; return -2; /* ERROR */ } - h = make_hypercube_range(dim, xmin, xmax); - status = ruleadapt_integrate(r, f, fdata, &h, - maxEval, reqAbsError, reqRelError, - &ee); - *val = ee.val; - *err = ee.err; - destroy_hypercube(&h); - destroy_rule(r); - return status; +static int ruleadapt_integrate(rule *r, integrand f, void *fdata, const hypercube *h, + unsigned maxEval, double reqAbsError, double reqRelError, + esterr *ee) { + unsigned maxIter; /* maximum number of adaptive subdivisions */ + heap regions; + unsigned i; + int status = -1; /* = ERROR */ + + if (maxEval) { + if (r->num_points > maxEval) return status; /* ERROR */ + maxIter = (maxEval - r->num_points) / (2 * r->num_points); + } + else + maxIter = UINT_MAX; + + regions = heap_alloc(1); + + heap_push(®ions, eval_region(make_region(h), f, fdata, r)); + /* another possibility is to specify some non-adaptive subdivisions: + if (initialRegions != 1) + partition(h, initialRegions, EQUIDISTANT, ®ions, f,fdata, r); */ + + for (i = 0; i < maxIter; ++i) { + region R, R2; + if (regions.ee.err <= reqAbsError || relError(regions.ee) <= reqRelError) { + status = 0; /* converged! */ + break; + } + R = heap_pop(®ions); /* get worst region */ + cut_region(&R, &R2); + heap_push(®ions, eval_region(R, f, fdata, r)); + heap_push(®ions, eval_region(R2, f, fdata, r)); + } + + ee->val = ee->err = 0; /* re-sum integral and errors */ + for (i = 0; i < regions.n; ++i) { + ee->val += regions.items[i].ee.val; + ee->err += regions.items[i].ee.err; + destroy_region(®ions.items[i]); + } + /* printf("regions.nalloc = %d\n", regions.nalloc); */ + heap_free(®ions); + + return status; +} + +static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, + const double *xmax, unsigned maxEval, double reqAbsError, + double reqRelError, double *val, double *err) { + rule *r; + hypercube h; + esterr ee; + int status; + + if (dim == 0) { /* trivial integration */ + *val = f(0, xmin, fdata); + *err = 0; + return 0; + } + r = dim == 1 ? make_rule15gauss(dim) : make_rule75genzmalik(dim); + if (!r) { + *val = 0; + *err = HUGE_VAL; + return -2; /* ERROR */ + } + h = make_hypercube_range(dim, xmin, xmax); + status = ruleadapt_integrate(r, f, fdata, &h, maxEval, reqAbsError, reqRelError, &ee); + *val = ee.val; + *err = ee.err; + destroy_hypercube(&h); + destroy_rule(r); + return status; } /***************************************************************************/ @@ -745,189 +699,162 @@ const double radius = 0.50124145262344534123412; /* random */ /* Simple constant function */ -double -fconst (double x[], size_t dim, void *params) -{ - return 1; -} +double fconst(double x[], size_t dim, void *params) { return 1; } /*** f0, f1, f2, and f3 are test functions from the Monte-Carlo integration routines in GSL 1.6 (monte/test.c). Copyright (c) 1996-2000 Michael Booth, GNU GPL. ****/ /* Simple product function */ -double f0 (unsigned dim, const double *x, void *params) -{ - double prod = 1.0; - unsigned int i; - for (i = 0; i < dim; ++i) - prod *= 2.0 * x[i]; - return prod; +double f0(unsigned dim, const double *x, void *params) { + double prod = 1.0; + unsigned int i; + for (i = 0; i < dim; ++i) + prod *= 2.0 * x[i]; + return prod; } /* Gaussian centered at 1/2. */ -double f1 (unsigned dim, const double *x, void *params) -{ - double a = *(double *)params; - double sum = 0.; - unsigned int i; - for (i = 0; i < dim; i++) { - double dx = x[i] - 0.5; - sum += dx * dx; - } - return (pow (M_2_SQRTPI / (2. * a), (double) dim) * - exp (-sum / (a * a))); +double f1(unsigned dim, const double *x, void *params) { + double a = *(double *)params; + double sum = 0.; + unsigned int i; + for (i = 0; i < dim; i++) { + double dx = x[i] - 0.5; + sum += dx * dx; + } + return (pow(M_2_SQRTPI / (2. * a), (double)dim) * exp(-sum / (a * a))); } /* double gaussian */ -double f2 (unsigned dim, const double *x, void *params) -{ - double a = *(double *)params; - double sum1 = 0.; - double sum2 = 0.; - unsigned int i; - for (i = 0; i < dim; i++) { - double dx1 = x[i] - 1. / 3.; - double dx2 = x[i] - 2. / 3.; - sum1 += dx1 * dx1; - sum2 += dx2 * dx2; - } - return 0.5 * pow (M_2_SQRTPI / (2. * a), dim) - * (exp (-sum1 / (a * a)) + exp (-sum2 / (a * a))); +double f2(unsigned dim, const double *x, void *params) { + double a = *(double *)params; + double sum1 = 0.; + double sum2 = 0.; + unsigned int i; + for (i = 0; i < dim; i++) { + double dx1 = x[i] - 1. / 3.; + double dx2 = x[i] - 2. / 3.; + sum1 += dx1 * dx1; + sum2 += dx2 * dx2; + } + return 0.5 * pow(M_2_SQRTPI / (2. * a), dim) * (exp(-sum1 / (a * a)) + exp(-sum2 / (a * a))); } /* Tsuda's example */ -double f3 (unsigned dim, const double *x, void *params) -{ - double c = *(double *)params; - double prod = 1.; - unsigned int i; - for (i = 0; i < dim; i++) - prod *= c / (c + 1) * pow((c + 1) / (c + x[i]), 2.0); - return prod; +double f3(unsigned dim, const double *x, void *params) { + double c = *(double *)params; + double prod = 1.; + unsigned int i; + for (i = 0; i < dim; i++) + prod *= c / (c + 1) * pow((c + 1) / (c + x[i]), 2.0); + return prod; } /*** end of GSL test functions ***/ -double f_test(unsigned dim, const double *x, void *data) -{ - double val; - unsigned i; - ++count; - switch (which_integrand) { - case 0: /* simple smooth (separable) objective: prod. cos(x[i]). */ - val = 1; - for (i = 0; i < dim; ++i) - val *= cos(x[i]); - break; - case 1: { /* integral of exp(-x^2), rescaled to (0,infinity) limits */ - double scale = 1.0; - val = 0; - for (i = 0; i < dim; ++i) { - double z = (1 - x[i]) / x[i]; - val += z * z; - scale *= M_2_SQRTPI / (x[i] * x[i]); - } - val = exp(-val) * scale; - break; - } - case 2: /* discontinuous objective: volume of hypersphere */ - val = 0; - for (i = 0; i < dim; ++i) - val += x[i] * x[i]; - val = val < radius * radius; - break; - case 3: - val = f0(dim, x, data); - break; - case 4: - val = f1(dim, x, data); - break; - case 5: - val = f2(dim, x, data); - break; - case 6: - val = f3(dim, x, data); - break; - default: - fprintf(stderr, "unknown integrand %d\n", which_integrand); - exit(EXIT_FAILURE); - } - /* if (count < 100) printf("%d: f(%g, ...) = %g\n", count, x[0], val); */ - return val; +double f_test(unsigned dim, const double *x, void *data) { + double val; + unsigned i; + ++count; + switch (which_integrand) { + case 0: /* simple smooth (separable) objective: prod. cos(x[i]). */ + val = 1; + for (i = 0; i < dim; ++i) + val *= cos(x[i]); + break; + case 1: { /* integral of exp(-x^2), rescaled to (0,infinity) limits */ + double scale = 1.0; + val = 0; + for (i = 0; i < dim; ++i) { + double z = (1 - x[i]) / x[i]; + val += z * z; + scale *= M_2_SQRTPI / (x[i] * x[i]); + } + val = exp(-val) * scale; + break; + } + case 2: /* discontinuous objective: volume of hypersphere */ + val = 0; + for (i = 0; i < dim; ++i) + val += x[i] * x[i]; + val = val < radius * radius; + break; + case 3: val = f0(dim, x, data); break; + case 4: val = f1(dim, x, data); break; + case 5: val = f2(dim, x, data); break; + case 6: val = f3(dim, x, data); break; + default: fprintf(stderr, "unknown integrand %d\n", which_integrand); exit(EXIT_FAILURE); + } + /* if (count < 100) printf("%d: f(%g, ...) = %g\n", count, x[0], val); */ + return val; } /* surface area of n-dimensional unit hypersphere */ -static double S(unsigned n) -{ - double val; - int fact = 1; - if (n % 2 == 0) { /* n even */ - val = 2 * pow(M_PI, n * 0.5); - n = n / 2; - while (n > 1) fact *= (n -= 1); - val /= fact; - } - else { /* n odd */ - val = (1 << (n/2 + 1)) * pow(M_PI, n/2); - while (n > 2) fact *= (n -= 2); - val /= fact; - } - return val; +static double S(unsigned n) { + double val; + int fact = 1; + if (n % 2 == 0) { /* n even */ + val = 2 * pow(M_PI, n * 0.5); + n = n / 2; + while (n > 1) + fact *= (n -= 1); + val /= fact; + } + else { /* n odd */ + val = (1 << (n / 2 + 1)) * pow(M_PI, n / 2); + while (n > 2) + fact *= (n -= 2); + val /= fact; + } + return val; } static double exact_integral(unsigned dim, const double *xmax) { - unsigned i; - double val; - switch(which_integrand) { - case 0: - val = 1; - for (i = 0; i < dim; ++i) - val *= sin(xmax[i]); - break; - case 2: - val = dim == 0 ? 1 : S(dim) * pow(radius * 0.5, dim) / dim; - break; - default: - val = 1.0; - } - return val; -} - -int main(int argc, char **argv) -{ - double *xmin, *xmax; - double tol, val, err; - unsigned i, dim, maxEval; - double fdata; - - dim = argc > 1 ? atoi(argv[1]) : 2; - tol = argc > 2 ? atof(argv[2]) : 1e-2; - which_integrand = argc > 3 ? atoi(argv[3]) : 0; - maxEval = argc > 4 ? atoi(argv[4]) : 0; - - fdata = which_integrand == 6 ? (1.0 + sqrt (10.0)) / 9.0 : 0.1; - - xmin = (double *) malloc(dim * sizeof(double)); - xmax = (double *) malloc(dim * sizeof(double)); - for (i = 0; i < dim; ++i) { - xmin[i] = 0; - xmax[i] = 1 + (which_integrand >= 1 ? 0 : 0.4 * sin(i)); - } - - printf("%u-dim integral, tolerance = %g, integrand = %d\n", - dim, tol, which_integrand); - adapt_integrate(f_test, &fdata, - dim, xmin, xmax, - maxEval, 0, tol, &val, &err); - printf("integration val = %g, est. err = %g, true err = %g\n", - val, err, fabs(val - exact_integral(dim, xmax))); - printf("#evals = %d\n", count); + unsigned i; + double val; + switch (which_integrand) { + case 0: + val = 1; + for (i = 0; i < dim; ++i) + val *= sin(xmax[i]); + break; + case 2: val = dim == 0 ? 1 : S(dim) * pow(radius * 0.5, dim) / dim; break; + default: val = 1.0; + } + return val; +} + +int main(int argc, char **argv) { + double *xmin, *xmax; + double tol, val, err; + unsigned i, dim, maxEval; + double fdata; + + dim = argc > 1 ? atoi(argv[1]) : 2; + tol = argc > 2 ? atof(argv[2]) : 1e-2; + which_integrand = argc > 3 ? atoi(argv[3]) : 0; + maxEval = argc > 4 ? atoi(argv[4]) : 0; + + fdata = which_integrand == 6 ? (1.0 + sqrt(10.0)) / 9.0 : 0.1; + + xmin = (double *)malloc(dim * sizeof(double)); + xmax = (double *)malloc(dim * sizeof(double)); + for (i = 0; i < dim; ++i) { + xmin[i] = 0; + xmax[i] = 1 + (which_integrand >= 1 ? 0 : 0.4 * sin(i)); + } + + printf("%u-dim integral, tolerance = %g, integrand = %d\n", dim, tol, which_integrand); + adapt_integrate(f_test, &fdata, dim, xmin, xmax, maxEval, 0, tol, &val, &err); + printf("integration val = %g, est. err = %g, true err = %g\n", val, err, + fabs(val - exact_integral(dim, xmax))); + printf("#evals = %d\n", count); - free(xmax); - free(xmin); + free(xmax); + free(xmin); - return 0; + return 0; } #else @@ -937,21 +864,17 @@ #include "ctl-math.h" -static int adapt_integrate(integrand f, void *fdata, - unsigned dim, const double *xmin, const double *xmax, - unsigned maxEval, - double reqAbsError, double reqRelError, - double *val, double *err); - -number adaptive_integration(multivar_func f, number *xmin, number *xmax, - integer n, void *fdata, - number abstol, number reltol, integer maxnfe, - number *esterr, integer *errflag) -{ - double val; - *errflag = adapt_integrate((integrand) f, fdata, n, xmin, xmax, - maxnfe, abstol, reltol, &val, esterr); - return val; +static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, + const double *xmax, unsigned maxEval, double reqAbsError, + double reqRelError, double *val, double *err); + +number adaptive_integration(multivar_func f, number *xmin, number *xmax, integer n, void *fdata, + number abstol, number reltol, integer maxnfe, number *esterr, + integer *errflag) { + double val; + *errflag = + adapt_integrate((integrand)f, fdata, n, xmin, xmax, maxnfe, abstol, reltol, &val, esterr); + return val; } #ifndef LIBCTLGEOM @@ -961,55 +884,46 @@ /* from subplex.c */ extern number f_scm_wrapper(integer n, number *x, void *f_scm_p); -SCM adaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, - SCM abstol_scm, SCM reltol_scm, SCM maxnfe_scm) -{ - integer n, maxnfe, errflag, i; - number *xmin, *xmax, abstol, reltol, integral; - - n = list_length(xmin_scm); - abstol = fabs(ctl_convert_number_to_c(abstol_scm)); - reltol = fabs(ctl_convert_number_to_c(reltol_scm)); - maxnfe = ctl_convert_integer_to_c(maxnfe_scm); - - if (list_length(xmax_scm) != n) { - fprintf(stderr, "adaptive_integration: xmin/xmax dimension mismatch\n"); - return SCM_UNDEFINED; - } - - xmin = (number*) malloc(sizeof(number) * n); - xmax = (number*) malloc(sizeof(number) * n); - if (!xmin || !xmax) { - fprintf(stderr, "adaptive_integration: error, out of memory!\n"); - exit(EXIT_FAILURE); - } - - for (i = 0; i < n; ++i) { - xmin[i] = number_list_ref(xmin_scm, i); - xmax[i] = number_list_ref(xmax_scm, i); - } - - integral = adaptive_integration(f_scm_wrapper, xmin, xmax, n, &f_scm, - abstol, reltol, maxnfe, - &abstol, &errflag); - - free(xmax); - free(xmin); - - switch (errflag) { - case 3: - fprintf(stderr, "adaptive_integration: invalid inputs\n"); - return SCM_UNDEFINED; - case 1: - fprintf(stderr, "adaptive_integration: maxnfe too small\n"); - break; - case 2: - fprintf(stderr, "adaptive_integration: lenwork too small\n"); - break; - } +SCM adaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, SCM abstol_scm, SCM reltol_scm, + SCM maxnfe_scm) { + integer n, maxnfe, errflag, i; + number *xmin, *xmax, abstol, reltol, integral; + + n = list_length(xmin_scm); + abstol = fabs(ctl_convert_number_to_c(abstol_scm)); + reltol = fabs(ctl_convert_number_to_c(reltol_scm)); + maxnfe = ctl_convert_integer_to_c(maxnfe_scm); + + if (list_length(xmax_scm) != n) { + fprintf(stderr, "adaptive_integration: xmin/xmax dimension mismatch\n"); + return SCM_UNDEFINED; + } + + xmin = (number *)malloc(sizeof(number) * n); + xmax = (number *)malloc(sizeof(number) * n); + if (!xmin || !xmax) { + fprintf(stderr, "adaptive_integration: error, out of memory!\n"); + exit(EXIT_FAILURE); + } + + for (i = 0; i < n; ++i) { + xmin[i] = number_list_ref(xmin_scm, i); + xmax[i] = number_list_ref(xmax_scm, i); + } + + integral = adaptive_integration(f_scm_wrapper, xmin, xmax, n, &f_scm, abstol, reltol, maxnfe, + &abstol, &errflag); + + free(xmax); + free(xmin); + + switch (errflag) { + case 3: fprintf(stderr, "adaptive_integration: invalid inputs\n"); return SCM_UNDEFINED; + case 1: fprintf(stderr, "adaptive_integration: maxnfe too small\n"); break; + case 2: fprintf(stderr, "adaptive_integration: lenwork too small\n"); break; + } - return gh_cons(ctl_convert_number_to_scm(integral), - ctl_convert_number_to_scm(abstol)); + return gh_cons(ctl_convert_number_to_scm(integral), ctl_convert_number_to_scm(abstol)); } #endif /* !LIBCTLGEOM */ diff -Nru libctl-4.4.0/src/subplex.c libctl-4.5.0/src/subplex.c --- libctl-4.4.0/src/subplex.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/src/subplex.c 2020-02-19 18:34:33.000000000 +0000 @@ -21,7 +21,7 @@ To build subplex on UNIX systems, edit the Makefile as necessary and type: - make + make This will create a linkable library named subplex.a and a demonstration executable named demo. @@ -29,7 +29,7 @@ EXAMPLE To run subplex on a simple objective function type: - demo < demo.in + demo < demo.in To run subplex on other problems, edit a copy of the sample driver demo.f as necessary. @@ -69,8 +69,8 @@ typedef multivar_func D_fp; -#define max(a,b) ((a) > (b) ? (a) : (b)) -#define min(a,b) ((a) < (b) ? (a) : (b)) +#define max(a, b) ((a) > (b) ? (a) : (b)) +#define min(a, b) ((a) < (b) ? (a) : (b)) #define abs(x) fabs(x) /****************************************************************************/ @@ -78,1080 +78,978 @@ /* dasum.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static doublereal dasum_(integer *n, doublereal *dx, integer *incx) -{ - /* System generated locals */ - integer i__1; - doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6; +static doublereal dasum_(integer *n, doublereal *dx, integer *incx) { + /* System generated locals */ + integer i__1; + doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + integer i__, m; + doublereal dtemp; + integer ix, mp1; + + /* takes the sum of the absolute values. */ + /* uses unrolled loops for increment equal to one. */ + /* jack dongarra, linpack, 3/11/78. */ + /* modified to correct problem with negative increment, 8/21/90. */ + + /* Parameter adjustments */ + --dx; + + /* Function Body */ + ret_val = 0.; + dtemp = 0.; + if (*n <= 0) { return ret_val; } + if (*incx == 1) { goto L20; } + + /* code for increment not equal to 1 */ + + ix = 1; + if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += (d__1 = dx[ix], abs(d__1)); + ix += *incx; + /* L10: */ + } + ret_val = dtemp; + return ret_val; - /* Local variables */ - integer i__, m; - doublereal dtemp; - integer ix, mp1; + /* code for increment equal to 1 */ - -/* takes the sum of the absolute values. */ -/* uses unrolled loops for increment equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified to correct problem with negative increment, 8/21/90. */ - - - /* Parameter adjustments */ - --dx; - - /* Function Body */ - ret_val = 0.; - dtemp = 0.; - if (*n <= 0) { - return ret_val; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - ix = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp += (d__1 = dx[ix], abs(d__1)); - ix += *incx; -/* L10: */ - } - ret_val = dtemp; - return ret_val; - -/* code for increment equal to 1 */ - - -/* clean-up loop */ + /* clean-up loop */ L20: - m = *n % 6; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp += (d__1 = dx[i__], abs(d__1)); -/* L30: */ - } - if (*n < 6) { - goto L60; - } + m = *n % 6; + if (m == 0) { goto L40; } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += (d__1 = dx[i__], abs(d__1)); + /* L30: */ + } + if (*n < 6) { goto L60; } L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 6) { - dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], - abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ - + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = - dx[i__ + 5], abs(d__6)); -/* L50: */ - } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 6) { + dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], abs(d__2)) + + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ + 3], abs(d__4)) + + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = dx[i__ + 5], abs(d__6)); + /* L50: */ + } L60: - ret_val = dtemp; - return ret_val; + ret_val = dtemp; + return ret_val; } /* dasum_ */ /* daxpy.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int daxpy_(integer *n, doublereal *da, doublereal *dx, - integer *incx, doublereal *dy, integer *incy) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - - -/* constant times a vector plus a vector. */ -/* uses unrolled loops for increments equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ - - - /* Parameter adjustments */ - --dy; - --dx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*da == 0.) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } - -/* code for unequal increments or equal increments */ -/* not equal to 1 */ - - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[iy] += *da * dx[ix]; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ +static int daxpy_(integer *n, doublereal *da, doublereal *dx, integer *incx, doublereal *dy, + integer *incy) { + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + + /* constant times a vector plus a vector. */ + /* uses unrolled loops for increments equal to one. */ + /* jack dongarra, linpack, 3/11/78. */ + + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { return 0; } + if (*da == 0.) { return 0; } + if (*incx == 1 && *incy == 1) { goto L20; } + + /* code for unequal increments or equal increments */ + /* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } + if (*incy < 0) { iy = (-(*n) + 1) * *incy + 1; } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[iy] += *da * dx[ix]; + ix += *incx; + iy += *incy; + /* L10: */ + } + return 0; + /* code for both increments equal to 1 */ -/* clean-up loop */ + /* clean-up loop */ L20: - m = *n % 4; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[i__] += *da * dx[i__]; -/* L30: */ - } - if (*n < 4) { - return 0; - } + m = *n % 4; + if (m == 0) { goto L40; } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] += *da * dx[i__]; + /* L30: */ + } + if (*n < 4) { return 0; } L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 4) { - dy[i__] += *da * dx[i__]; - dy[i__ + 1] += *da * dx[i__ + 1]; - dy[i__ + 2] += *da * dx[i__ + 2]; - dy[i__ + 3] += *da * dx[i__ + 3]; -/* L50: */ - } - return 0; + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 4) { + dy[i__] += *da * dx[i__]; + dy[i__ + 1] += *da * dx[i__ + 1]; + dy[i__ + 2] += *da * dx[i__ + 2]; + dy[i__ + 3] += *da * dx[i__ + 3]; + /* L50: */ + } + return 0; } /* daxpy_ */ /* dcopy.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int dcopy_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy) -{ - /* System generated locals */ - integer i__1; +static int dcopy_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy) { + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + + /* copies a vector, x, to a vector, y. */ + /* uses unrolled loops for increments equal to one. */ + /* jack dongarra, linpack, 3/11/78. */ + + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { return 0; } + if (*incx == 1 && *incy == 1) { goto L20; } + + /* code for unequal increments or equal increments */ + /* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } + if (*incy < 0) { iy = (-(*n) + 1) * *incy + 1; } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[iy] = dx[ix]; + ix += *incx; + iy += *incy; + /* L10: */ + } + return 0; - /* Local variables */ - integer i__, m, ix, iy, mp1; + /* code for both increments equal to 1 */ - -/* copies a vector, x, to a vector, y. */ -/* uses unrolled loops for increments equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ - - - /* Parameter adjustments */ - --dy; - --dx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } - -/* code for unequal increments or equal increments */ -/* not equal to 1 */ - - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[iy] = dx[ix]; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - - -/* clean-up loop */ + /* clean-up loop */ L20: - m = *n % 7; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[i__] = dx[i__]; -/* L30: */ - } - if (*n < 7) { - return 0; - } + m = *n % 7; + if (m == 0) { goto L40; } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] = dx[i__]; + /* L30: */ + } + if (*n < 7) { return 0; } L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 7) { - dy[i__] = dx[i__]; - dy[i__ + 1] = dx[i__ + 1]; - dy[i__ + 2] = dx[i__ + 2]; - dy[i__ + 3] = dx[i__ + 3]; - dy[i__ + 4] = dx[i__ + 4]; - dy[i__ + 5] = dx[i__ + 5]; - dy[i__ + 6] = dx[i__ + 6]; -/* L50: */ - } - return 0; + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 7) { + dy[i__] = dx[i__]; + dy[i__ + 1] = dx[i__ + 1]; + dy[i__ + 2] = dx[i__ + 2]; + dy[i__ + 3] = dx[i__ + 3]; + dy[i__ + 4] = dx[i__ + 4]; + dy[i__ + 5] = dx[i__ + 5]; + dy[i__ + 6] = dx[i__ + 6]; + /* L50: */ + } + return 0; } /* dcopy_ */ /* dscal.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int dscal_(integer *n, doublereal *da, doublereal *dx, - integer *incx) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, m, ix, mp1; +static int dscal_(integer *n, doublereal *da, doublereal *dx, integer *incx) { + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, mp1; + + /* scales a vector by a constant. */ + /* uses unrolled loops for increment equal to one. */ + /* jack dongarra, linpack, 3/11/78. */ + /* modified to correct problem with negative increment, 8/21/90. */ + + /* Parameter adjustments */ + --dx; + + /* Function Body */ + if (*n <= 0) { return 0; } + if (*incx == 1) { goto L20; } + + /* code for increment not equal to 1 */ + + ix = 1; + if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dx[ix] = *da * dx[ix]; + ix += *incx; + /* L10: */ + } + return 0; + /* code for increment equal to 1 */ -/* scales a vector by a constant. */ -/* uses unrolled loops for increment equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified to correct problem with negative increment, 8/21/90. */ - - - /* Parameter adjustments */ - --dx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - ix = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dx[ix] = *da * dx[ix]; - ix += *incx; -/* L10: */ - } - return 0; - -/* code for increment equal to 1 */ - - -/* clean-up loop */ + /* clean-up loop */ L20: - m = *n % 5; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dx[i__] = *da * dx[i__]; -/* L30: */ - } - if (*n < 5) { - return 0; - } + m = *n % 5; + if (m == 0) { goto L40; } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dx[i__] = *da * dx[i__]; + /* L30: */ + } + if (*n < 5) { return 0; } L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 5) { - dx[i__] = *da * dx[i__]; - dx[i__ + 1] = *da * dx[i__ + 1]; - dx[i__ + 2] = *da * dx[i__ + 2]; - dx[i__ + 3] = *da * dx[i__ + 3]; - dx[i__ + 4] = *da * dx[i__ + 4]; -/* L50: */ - } - return 0; + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 5) { + dx[i__] = *da * dx[i__]; + dx[i__ + 1] = *da * dx[i__ + 1]; + dx[i__ + 2] = *da * dx[i__ + 2]; + dx[i__ + 3] = *da * dx[i__ + 3]; + dx[i__ + 4] = *da * dx[i__ + 4]; + /* L50: */ + } + return 0; } /* dscal_ */ /* dist.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static doublereal dist_(integer *n, doublereal *x, doublereal *y) -{ - /* System generated locals */ - integer i__1; - doublereal ret_val, d__1; +static doublereal dist_(integer *n, doublereal *x, doublereal *y) { + /* System generated locals */ + integer i__1; + doublereal ret_val, d__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + integer i__; + doublereal scale, absxmy, sum; + + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ + + /* dist calculates the distance between the points x,y. */ + + /* input */ + + /* n - number of components */ + + /* x - point in n-space */ + + /* y - point in n-space */ + + /* local variables */ + + /* subroutines and functions */ + + /* fortran */ + + /* ----------------------------------------------------------- */ + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + absxmy = (d__1 = x[1] - y[1], abs(d__1)); + if (absxmy <= 1.) { + sum = absxmy * absxmy; + scale = 1.; + } + else { + sum = 1.; + scale = absxmy; + } + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + absxmy = (d__1 = x[i__] - y[i__], abs(d__1)); + if (absxmy <= scale) { + /* Computing 2nd power */ + d__1 = absxmy / scale; + sum += d__1 * d__1; + } + else { + /* Computing 2nd power */ + d__1 = scale / absxmy; + sum = sum * (d__1 * d__1) + 1.; + scale = absxmy; + } + /* L10: */ + } + ret_val = scale * sqrt(sum); + return ret_val; +} /* dist_ */ - /* Builtin functions */ - double sqrt(doublereal); +/* calcc.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ - /* Local variables */ - integer i__; - doublereal scale, absxmy, sum; +/* Table of constant values */ +static doublereal c_b3 = 0.; +static integer c__0 = 0; +static integer c__1 = 1; +static doublereal c_b7 = 1.; +static int calcc_(integer *ns, doublereal *s, integer *ih, integer *inew, logical *updatc, + doublereal *c__) { + /* System generated locals */ + integer s_dim1, s_offset, i__1; + doublereal d__1; -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ + /* Local variables */ + integer i__, j; -/* dist calculates the distance between the points x,y. */ + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ -/* input */ + /* calcc calculates the centroid of the simplex without the */ + /* vertex with highest function value. */ -/* n - number of components */ + /* input */ -/* x - point in n-space */ + /* ns - subspace dimension */ -/* y - point in n-space */ + /* s - double precision work space of dimension .ge. */ + /* ns*(ns+3) used to store simplex */ -/* local variables */ + /* ih - index to vertex with highest function value */ + /* inew - index to new point */ -/* subroutines and functions */ + /* updatc - logical switch */ + /* = .true. : update centroid */ + /* = .false. : calculate centroid from scratch */ -/* fortran */ + /* c - centroid of the simplex without vertex with */ + /* highest function value */ -/* ----------------------------------------------------------- */ + /* output */ - /* Parameter adjustments */ - --y; - --x; + /* c - new centroid */ - /* Function Body */ - absxmy = (d__1 = x[1] - y[1], abs(d__1)); - if (absxmy <= 1.) { - sum = absxmy * absxmy; - scale = 1.; - } else { - sum = 1.; - scale = absxmy; - } - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - absxmy = (d__1 = x[i__] - y[i__], abs(d__1)); - if (absxmy <= scale) { -/* Computing 2nd power */ - d__1 = absxmy / scale; - sum += d__1 * d__1; - } else { -/* Computing 2nd power */ - d__1 = scale / absxmy; - sum = sum * (d__1 * d__1) + 1.; - scale = absxmy; - } -/* L10: */ - } - ret_val = scale * sqrt(sum); - return ret_val; -} /* dist_ */ + /* local variables */ -/* calcc.f -- translated by f2c (version 19991025). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ + /* subroutines and functions */ -/* Table of constant values */ + /* blas */ -static doublereal c_b3 = 0.; -static integer c__0 = 0; -static integer c__1 = 1; -static doublereal c_b7 = 1.; + /* ----------------------------------------------------------- */ + + /* Parameter adjustments */ + --c__; + s_dim1 = *ns; + s_offset = 1 + s_dim1 * 1; + s -= s_offset; -static int calcc_(integer *ns, doublereal *s, integer *ih, integer * - inew, logical *updatc, doublereal *c__) -{ - /* System generated locals */ - integer s_dim1, s_offset, i__1; - doublereal d__1; - - /* Local variables */ - integer i__, j; - -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ - -/* calcc calculates the centroid of the simplex without the */ -/* vertex with highest function value. */ - -/* input */ - -/* ns - subspace dimension */ - -/* s - double precision work space of dimension .ge. */ -/* ns*(ns+3) used to store simplex */ - -/* ih - index to vertex with highest function value */ - -/* inew - index to new point */ - -/* updatc - logical switch */ -/* = .true. : update centroid */ -/* = .false. : calculate centroid from scratch */ - -/* c - centroid of the simplex without vertex with */ -/* highest function value */ - -/* output */ - -/* c - new centroid */ - -/* local variables */ - - -/* subroutines and functions */ - -/* blas */ - -/* ----------------------------------------------------------- */ - - /* Parameter adjustments */ - --c__; - s_dim1 = *ns; - s_offset = 1 + s_dim1 * 1; - s -= s_offset; - - /* Function Body */ - if (*updatc) { - if (*ih == *inew) { - return 0; - } - i__1 = *ns; - for (i__ = 1; i__ <= i__1; ++i__) { - c__[i__] += (s[i__ + *inew * s_dim1] - s[i__ + *ih * s_dim1]) / * - ns; -/* L10: */ - } - } else { - dcopy_(ns, &c_b3, &c__0, &c__[1], &c__1); - i__1 = *ns + 1; - for (j = 1; j <= i__1; ++j) { - if (j != *ih) { - daxpy_(ns, &c_b7, &s[j * s_dim1 + 1], &c__1, &c__[1], &c__1); - } -/* L20: */ - } - d__1 = 1. / *ns; - dscal_(ns, &d__1, &c__[1], &c__1); + /* Function Body */ + if (*updatc) { + if (*ih == *inew) { return 0; } + i__1 = *ns; + for (i__ = 1; i__ <= i__1; ++i__) { + c__[i__] += (s[i__ + *inew * s_dim1] - s[i__ + *ih * s_dim1]) / *ns; + /* L10: */ } - return 0; + } + else { + dcopy_(ns, &c_b3, &c__0, &c__[1], &c__1); + i__1 = *ns + 1; + for (j = 1; j <= i__1; ++j) { + if (j != *ih) { daxpy_(ns, &c_b7, &s[j * s_dim1 + 1], &c__1, &c__[1], &c__1); } + /* L20: */ + } + d__1 = 1. / *ns; + dscal_(ns, &d__1, &c__[1], &c__1); + } + return 0; } /* calcc_ */ /* order.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int order_(integer *npts, doublereal *fs, integer *il, - integer *is, integer *ih) -{ - /* System generated locals */ - integer i__1; +static int order_(integer *npts, doublereal *fs, integer *il, integer *is, integer *ih) { + /* System generated locals */ + integer i__1; - /* Local variables */ - integer i__, j, il0; + /* Local variables */ + integer i__, j, il0; + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ + /* order determines the indices of the vertices with the */ + /* lowest, second highest, and highest function values. */ -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ + /* input */ -/* order determines the indices of the vertices with the */ -/* lowest, second highest, and highest function values. */ + /* npts - number of points in simplex */ -/* input */ + /* fs - double precision vector of function values of */ + /* simplex */ -/* npts - number of points in simplex */ + /* il - index to vertex with lowest function value */ -/* fs - double precision vector of function values of */ -/* simplex */ + /* output */ -/* il - index to vertex with lowest function value */ + /* il - new index to vertex with lowest function value */ -/* output */ + /* is - new index to vertex with second highest */ + /* function value */ -/* il - new index to vertex with lowest function value */ + /* ih - new index to vertex with highest function value */ -/* is - new index to vertex with second highest */ -/* function value */ + /* local variables */ -/* ih - new index to vertex with highest function value */ + /* subroutines and functions */ -/* local variables */ + /* fortran */ + /* ----------------------------------------------------------- */ -/* subroutines and functions */ + /* Parameter adjustments */ + --fs; -/* fortran */ - -/* ----------------------------------------------------------- */ - - /* Parameter adjustments */ - --fs; - - /* Function Body */ - il0 = *il; - j = il0 % *npts + 1; - if (fs[j] >= fs[*il]) { - *ih = j; - *is = il0; - } else { - *ih = il0; - *is = j; - *il = j; + /* Function Body */ + il0 = *il; + j = il0 % *npts + 1; + if (fs[j] >= fs[*il]) { + *ih = j; + *is = il0; + } + else { + *ih = il0; + *is = j; + *il = j; + } + i__1 = il0 + *npts - 2; + for (i__ = il0 + 1; i__ <= i__1; ++i__) { + j = i__ % *npts + 1; + if (fs[j] >= fs[*ih]) { + *is = *ih; + *ih = j; } - i__1 = il0 + *npts - 2; - for (i__ = il0 + 1; i__ <= i__1; ++i__) { - j = i__ % *npts + 1; - if (fs[j] >= fs[*ih]) { - *is = *ih; - *ih = j; - } else if (fs[j] > fs[*is]) { - *is = j; - } else if (fs[j] < fs[*il]) { - *il = j; - } -/* L10: */ + else if (fs[j] > fs[*is]) { + *is = j; } - return 0; + else if (fs[j] < fs[*il]) { + *il = j; + } + /* L10: */ + } + return 0; } /* order_ */ /* partx.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ /* Common Block Declarations */ static struct { - doublereal alpha, beta, gamma, delta, psi, omega; - integer nsmin, nsmax, irepl, ifxsw; - doublereal bonus, fstop; - integer nfstop, nfxe; - doublereal fxstat[4], ftest; - logical minf, initx, newx; + doublereal alpha, beta, gamma, delta, psi, omega; + integer nsmin, nsmax, irepl, ifxsw; + doublereal bonus, fstop; + integer nfstop, nfxe; + doublereal fxstat[4], ftest; + logical minf, initx, newx; } usubc_; #define usubc_1 usubc_ -static int partx_(integer *n, integer *ip, doublereal *absdx, - integer *nsubs, integer *nsvals) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - static integer i__, nleft, nused; - static doublereal as1max, gapmax, asleft, as1, as2; - static integer ns1, ns2; - static doublereal gap; - - +static int partx_(integer *n, integer *ip, doublereal *absdx, integer *nsubs, integer *nsvals) { + /* System generated locals */ + integer i__1; -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ + /* Local variables */ + static integer i__, nleft, nused; + static doublereal as1max, gapmax, asleft, as1, as2; + static integer ns1, ns2; + static doublereal gap; -/* partx partitions the vector x by grouping components of */ -/* similar magnitude of change. */ + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ -/* input */ + /* partx partitions the vector x by grouping components of */ + /* similar magnitude of change. */ -/* n - number of components (problem dimension) */ + /* input */ -/* ip - permutation vector */ + /* n - number of components (problem dimension) */ -/* absdx - vector of magnitude of change in x */ + /* ip - permutation vector */ -/* nsvals - integer array dimensioned .ge. int(n/nsmin) */ + /* absdx - vector of magnitude of change in x */ -/* output */ + /* nsvals - integer array dimensioned .ge. int(n/nsmin) */ -/* nsubs - number of subspaces */ + /* output */ -/* nsvals - integer array of subspace dimensions */ + /* nsubs - number of subspaces */ -/* common */ + /* nsvals - integer array of subspace dimensions */ + /* common */ + /* local variables */ -/* local variables */ + /* subroutines and functions */ + /* fortran */ + /* ----------------------------------------------------------- */ -/* subroutines and functions */ + /* Parameter adjustments */ + --absdx; + --ip; + --nsvals; -/* fortran */ - -/* ----------------------------------------------------------- */ - - /* Parameter adjustments */ - --absdx; - --ip; - --nsvals; - - /* Function Body */ - *nsubs = 0; - nused = 0; - nleft = *n; - asleft = absdx[1]; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - asleft += absdx[i__]; -/* L10: */ - } + /* Function Body */ + *nsubs = 0; + nused = 0; + nleft = *n; + asleft = absdx[1]; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + asleft += absdx[i__]; + /* L10: */ + } L20: - if (nused < *n) { - ++(*nsubs); - as1 = 0.; - i__1 = usubc_1.nsmin - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - as1 += absdx[ip[nused + i__]]; -/* L30: */ - } - gapmax = -1.; - i__1 = min(usubc_1.nsmax,nleft); - for (ns1 = usubc_1.nsmin; ns1 <= i__1; ++ns1) { - as1 += absdx[ip[nused + ns1]]; - ns2 = nleft - ns1; - if (ns2 > 0) { - if (ns2 >= ((ns2 - 1) / usubc_1.nsmax + 1) * usubc_1.nsmin) { - as2 = asleft - as1; - gap = as1 / ns1 - as2 / ns2; - if (gap > gapmax) { - gapmax = gap; - nsvals[*nsubs] = ns1; - as1max = as1; - } - } - } else { - if (as1 / ns1 > gapmax) { - nsvals[*nsubs] = ns1; - return 0; - } - } -/* L40: */ - } - nused += nsvals[*nsubs]; - nleft = *n - nused; - asleft -= as1max; - goto L20; + if (nused < *n) { + ++(*nsubs); + as1 = 0.; + i__1 = usubc_1.nsmin - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + as1 += absdx[ip[nused + i__]]; + /* L30: */ } - return 0; + gapmax = -1.; + i__1 = min(usubc_1.nsmax, nleft); + for (ns1 = usubc_1.nsmin; ns1 <= i__1; ++ns1) { + as1 += absdx[ip[nused + ns1]]; + ns2 = nleft - ns1; + if (ns2 > 0) { + if (ns2 >= ((ns2 - 1) / usubc_1.nsmax + 1) * usubc_1.nsmin) { + as2 = asleft - as1; + gap = as1 / ns1 - as2 / ns2; + if (gap > gapmax) { + gapmax = gap; + nsvals[*nsubs] = ns1; + as1max = as1; + } + } + } + else { + if (as1 / ns1 > gapmax) { + nsvals[*nsubs] = ns1; + return 0; + } + } + /* L40: */ + } + nused += nsvals[*nsubs]; + nleft = *n - nused; + asleft -= as1max; + goto L20; + } + return 0; } /* partx_ */ /* sortd.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int sortd_(integer *n, doublereal *xkey, integer *ix) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer ixip1, i__, ilast, iswap, ifirst, ixi; - +static int sortd_(integer *n, doublereal *xkey, integer *ix) { + /* System generated locals */ + integer i__1; + /* Local variables */ + integer ixip1, i__, ilast, iswap, ifirst, ixi; -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ -/* sortd uses the shakersort method to sort an array of keys */ -/* in decreasing order. The sort is performed implicitly by */ -/* modifying a vector of indices. */ + /* sortd uses the shakersort method to sort an array of keys */ + /* in decreasing order. The sort is performed implicitly by */ + /* modifying a vector of indices. */ -/* For nearly sorted arrays, sortd requires O(n) comparisons. */ -/* for completely unsorted arrays, sortd requires O(n**2) */ -/* comparisons and will be inefficient unless n is small. */ + /* For nearly sorted arrays, sortd requires O(n) comparisons. */ + /* for completely unsorted arrays, sortd requires O(n**2) */ + /* comparisons and will be inefficient unless n is small. */ -/* input */ + /* input */ -/* n - number of components */ + /* n - number of components */ -/* xkey - double precision vector of keys */ + /* xkey - double precision vector of keys */ -/* ix - integer vector of indices */ + /* ix - integer vector of indices */ -/* output */ + /* output */ -/* ix - indices satisfy xkey(ix(i)) .ge. xkey(ix(i+1)) */ -/* for i = 1,...,n-1 */ + /* ix - indices satisfy xkey(ix(i)) .ge. xkey(ix(i+1)) */ + /* for i = 1,...,n-1 */ -/* local variables */ + /* local variables */ + /* ----------------------------------------------------------- */ -/* ----------------------------------------------------------- */ + /* Parameter adjustments */ + --ix; + --xkey; - /* Parameter adjustments */ - --ix; - --xkey; - - /* Function Body */ - ifirst = 1; - iswap = 1; - ilast = *n - 1; + /* Function Body */ + ifirst = 1; + iswap = 1; + ilast = *n - 1; L10: - if (ifirst <= ilast) { - i__1 = ilast; - for (i__ = ifirst; i__ <= i__1; ++i__) { - ixi = ix[i__]; - ixip1 = ix[i__ + 1]; - if (xkey[ixi] < xkey[ixip1]) { - ix[i__] = ixip1; - ix[i__ + 1] = ixi; - iswap = i__; - } -/* L20: */ - } - ilast = iswap - 1; - i__1 = ifirst; - for (i__ = ilast; i__ >= i__1; --i__) { - ixi = ix[i__]; - ixip1 = ix[i__ + 1]; - if (xkey[ixi] < xkey[ixip1]) { - ix[i__] = ixip1; - ix[i__ + 1] = ixi; - iswap = i__; - } -/* L30: */ - } - ifirst = iswap + 1; - goto L10; - } - return 0; + if (ifirst <= ilast) { + i__1 = ilast; + for (i__ = ifirst; i__ <= i__1; ++i__) { + ixi = ix[i__]; + ixip1 = ix[i__ + 1]; + if (xkey[ixi] < xkey[ixip1]) { + ix[i__] = ixip1; + ix[i__ + 1] = ixi; + iswap = i__; + } + /* L20: */ + } + ilast = iswap - 1; + i__1 = ifirst; + for (i__ = ilast; i__ >= i__1; --i__) { + ixi = ix[i__]; + ixip1 = ix[i__ + 1]; + if (xkey[ixi] < xkey[ixip1]) { + ix[i__] = ixip1; + ix[i__ + 1] = ixi; + iswap = i__; + } + /* L30: */ + } + ifirst = iswap + 1; + goto L10; + } + return 0; } /* sortd_ */ /* newpt.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int newpt_(integer *ns, doublereal *coef, doublereal *xbase, - doublereal *xold, logical *new__, doublereal *xnew, logical *small) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__; - logical eqold; - doublereal xoldi; - logical eqbase; +static int newpt_(integer *ns, doublereal *coef, doublereal *xbase, doublereal *xold, + logical *new__, doublereal *xnew, logical *small) { + /* System generated locals */ + integer i__1; + /* Local variables */ + integer i__; + logical eqold; + doublereal xoldi; + logical eqbase; + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ + /* newpt performs reflections, expansions, contractions, and */ + /* shrinkages (massive contractions) by computing: */ -/* newpt performs reflections, expansions, contractions, and */ -/* shrinkages (massive contractions) by computing: */ + /* xbase + coef * (xbase - xold) */ -/* xbase + coef * (xbase - xold) */ + /* The result is stored in xnew if new .eq. .true., */ + /* in xold otherwise. */ -/* The result is stored in xnew if new .eq. .true., */ -/* in xold otherwise. */ + /* use : coef .gt. 0 to reflect */ + /* coef .lt. 0 to expand, contract, or shrink */ -/* use : coef .gt. 0 to reflect */ -/* coef .lt. 0 to expand, contract, or shrink */ + /* input */ -/* input */ + /* ns - number of components (subspace dimension) */ -/* ns - number of components (subspace dimension) */ + /* coef - one of four simplex method coefficients */ -/* coef - one of four simplex method coefficients */ + /* xbase - double precision ns-vector representing base */ + /* point */ -/* xbase - double precision ns-vector representing base */ -/* point */ + /* xold - double precision ns-vector representing old */ + /* point */ -/* xold - double precision ns-vector representing old */ -/* point */ + /* new - logical switch */ + /* = .true. : store result in xnew */ + /* = .false. : store result in xold, xnew is not */ + /* referenced */ -/* new - logical switch */ -/* = .true. : store result in xnew */ -/* = .false. : store result in xold, xnew is not */ -/* referenced */ + /* output */ -/* output */ + /* xold - unchanged if new .eq. .true., contains new */ + /* point otherwise */ -/* xold - unchanged if new .eq. .true., contains new */ -/* point otherwise */ + /* xnew - double precision ns-vector representing new */ + /* point if new .eq. .true., not referenced */ + /* otherwise */ -/* xnew - double precision ns-vector representing new */ -/* point if new .eq. .true., not referenced */ -/* otherwise */ + /* small - logical flag */ + /* = .true. : coincident points */ + /* = .false. : otherwise */ -/* small - logical flag */ -/* = .true. : coincident points */ -/* = .false. : otherwise */ + /* local variables */ -/* local variables */ + /* subroutines and functions */ + /* fortran */ -/* subroutines and functions */ + /* ----------------------------------------------------------- */ -/* fortran */ + /* Parameter adjustments */ + --xold; + --xbase; + --xnew; -/* ----------------------------------------------------------- */ - - /* Parameter adjustments */ - --xold; - --xbase; - --xnew; - - /* Function Body */ - eqbase = TRUE_; - eqold = TRUE_; - if (*new__) { - i__1 = *ns; - for (i__ = 1; i__ <= i__1; ++i__) { - xnew[i__] = xbase[i__] + *coef * (xbase[i__] - xold[i__]); - eqbase = eqbase && xnew[i__] == xbase[i__]; - eqold = eqold && xnew[i__] == xold[i__]; -/* L10: */ - } - } else { - i__1 = *ns; - for (i__ = 1; i__ <= i__1; ++i__) { - xoldi = xold[i__]; - xold[i__] = xbase[i__] + *coef * (xbase[i__] - xold[i__]); - eqbase = eqbase && xold[i__] == xbase[i__]; - eqold = eqold && xold[i__] == xoldi; -/* L20: */ - } + /* Function Body */ + eqbase = TRUE_; + eqold = TRUE_; + if (*new__) { + i__1 = *ns; + for (i__ = 1; i__ <= i__1; ++i__) { + xnew[i__] = xbase[i__] + *coef * (xbase[i__] - xold[i__]); + eqbase = eqbase && xnew[i__] == xbase[i__]; + eqold = eqold && xnew[i__] == xold[i__]; + /* L10: */ } - *small = eqbase || eqold; - return 0; + } + else { + i__1 = *ns; + for (i__ = 1; i__ <= i__1; ++i__) { + xoldi = xold[i__]; + xold[i__] = xbase[i__] + *coef * (xbase[i__] - xold[i__]); + eqbase = eqbase && xold[i__] == xbase[i__]; + eqold = eqold && xold[i__] == xoldi; + /* L20: */ + } + } + *small = eqbase || eqold; + return 0; } /* newpt_ */ /* start.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int start_(integer *n, doublereal *x, doublereal *step, - integer *ns, integer *ips, doublereal *s, logical *small) -{ - /* System generated locals */ - integer s_dim1, s_offset, i__1; +static int start_(integer *n, doublereal *x, doublereal *step, integer *ns, integer *ips, + doublereal *s, logical *small) { + /* System generated locals */ + integer s_dim1, s_offset, i__1; - /* Local variables */ - integer i__, j; + /* Local variables */ + integer i__, j; + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ + /* start creates the initial simplex for simplx minimization. */ -/* start creates the initial simplex for simplx minimization. */ + /* input */ -/* input */ + /* n - problem dimension */ -/* n - problem dimension */ + /* x - current best point */ -/* x - current best point */ + /* step - stepsizes for corresponding components of x */ -/* step - stepsizes for corresponding components of x */ + /* ns - subspace dimension */ -/* ns - subspace dimension */ + /* ips - permutation vector */ -/* ips - permutation vector */ + /* output */ + /* s - first ns+1 columns contain initial simplex */ -/* output */ + /* small - logical flag */ + /* = .true. : coincident points */ + /* = .false. : otherwise */ -/* s - first ns+1 columns contain initial simplex */ + /* local variables */ -/* small - logical flag */ -/* = .true. : coincident points */ -/* = .false. : otherwise */ + /* subroutines and functions */ -/* local variables */ + /* blas */ + /* fortran */ + /* ----------------------------------------------------------- */ -/* subroutines and functions */ + /* Parameter adjustments */ + --ips; + --step; + --x; + s_dim1 = *ns; + s_offset = 1 + s_dim1 * 1; + s -= s_offset; -/* blas */ -/* fortran */ + (void)n; /* unused */ -/* ----------------------------------------------------------- */ + /* Function Body */ + i__1 = *ns; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__ + s_dim1] = x[ips[i__]]; + /* L10: */ + } + i__1 = *ns + 1; + for (j = 2; j <= i__1; ++j) { + dcopy_(ns, &s[s_dim1 + 1], &c__1, &s[j * s_dim1 + 1], &c__1); + s[j - 1 + j * s_dim1] = s[j - 1 + s_dim1] + step[ips[j - 1]]; + /* L20: */ + } - /* Parameter adjustments */ - --ips; - --step; - --x; - s_dim1 = *ns; - s_offset = 1 + s_dim1 * 1; - s -= s_offset; + /* check for coincident points */ - (void)n; /* unused */ + i__1 = *ns + 1; + for (j = 2; j <= i__1; ++j) { + if (s[j - 1 + j * s_dim1] == s[j - 1 + s_dim1]) { goto L40; } + /* L30: */ + } + *small = FALSE_; + return 0; - /* Function Body */ - i__1 = *ns; - for (i__ = 1; i__ <= i__1; ++i__) { - s[i__ + s_dim1] = x[ips[i__]]; -/* L10: */ - } - i__1 = *ns + 1; - for (j = 2; j <= i__1; ++j) { - dcopy_(ns, &s[s_dim1 + 1], &c__1, &s[j * s_dim1 + 1], &c__1); - s[j - 1 + j * s_dim1] = s[j - 1 + s_dim1] + step[ips[j - 1]]; -/* L20: */ - } - -/* check for coincident points */ - - i__1 = *ns + 1; - for (j = 2; j <= i__1; ++j) { - if (s[j - 1 + j * s_dim1] == s[j - 1 + s_dim1]) { - goto L40; - } -/* L30: */ - } - *small = FALSE_; - return 0; - -/* coincident points */ + /* coincident points */ L40: - *small = TRUE_; - return 0; + *small = TRUE_; + return 0; } /* start_ */ /* fstats.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int fstats_(doublereal *fx, integer *ifxwt, logical *reset) -{ - /* System generated locals */ - doublereal d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - static doublereal fscale; - static integer nsv; - static doublereal f1sv; - - - -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ - -/* fstats modifies the common /usubc/ variables nfxe,fxstat. */ - -/* input */ - -/* fx - most recent evaluation of f at best x */ - -/* ifxwt - integer weight for fx */ - -/* reset - logical switch */ -/* = .true. : initialize nfxe,fxstat */ -/* = .false. : update nfxe,fxstat */ - -/* common */ - - - -/* local variables */ - - - -/* subroutines and functions */ - -/* fortran */ - -/* ----------------------------------------------------------- */ - - if (*reset) { - usubc_1.nfxe = *ifxwt; - usubc_1.fxstat[0] = *fx; - usubc_1.fxstat[1] = *fx; - usubc_1.fxstat[2] = *fx; - usubc_1.fxstat[3] = 0.; - } else { - nsv = usubc_1.nfxe; - f1sv = usubc_1.fxstat[0]; - usubc_1.nfxe += *ifxwt; - usubc_1.fxstat[0] += *ifxwt * (*fx - usubc_1.fxstat[0]) / - usubc_1.nfxe; - usubc_1.fxstat[1] = max(usubc_1.fxstat[1],*fx); - usubc_1.fxstat[2] = min(usubc_1.fxstat[2],*fx); -/* Computing MAX */ - d__1 = abs(usubc_1.fxstat[1]), d__2 = abs(usubc_1.fxstat[2]), d__1 = - max(d__1,d__2); - fscale = max(d__1,1.); -/* Computing 2nd power */ - d__1 = usubc_1.fxstat[3] / fscale; -/* Computing 2nd power */ - d__2 = (usubc_1.fxstat[0] - f1sv) / fscale; -/* Computing 2nd power */ - d__3 = (*fx - usubc_1.fxstat[0]) / fscale; - usubc_1.fxstat[3] = fscale * sqrt(((nsv - 1) * (d__1 * d__1) + nsv * ( - d__2 * d__2) + *ifxwt * (d__3 * d__3)) / (usubc_1.nfxe - 1)); - } - return 0; +static int fstats_(doublereal *fx, integer *ifxwt, logical *reset) { + /* System generated locals */ + doublereal d__1, d__2, d__3; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static doublereal fscale; + static integer nsv; + static doublereal f1sv; + + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ + + /* fstats modifies the common /usubc/ variables nfxe,fxstat. */ + + /* input */ + + /* fx - most recent evaluation of f at best x */ + + /* ifxwt - integer weight for fx */ + + /* reset - logical switch */ + /* = .true. : initialize nfxe,fxstat */ + /* = .false. : update nfxe,fxstat */ + + /* common */ + + /* local variables */ + + /* subroutines and functions */ + + /* fortran */ + + /* ----------------------------------------------------------- */ + + if (*reset) { + usubc_1.nfxe = *ifxwt; + usubc_1.fxstat[0] = *fx; + usubc_1.fxstat[1] = *fx; + usubc_1.fxstat[2] = *fx; + usubc_1.fxstat[3] = 0.; + } + else { + nsv = usubc_1.nfxe; + f1sv = usubc_1.fxstat[0]; + usubc_1.nfxe += *ifxwt; + usubc_1.fxstat[0] += *ifxwt * (*fx - usubc_1.fxstat[0]) / usubc_1.nfxe; + usubc_1.fxstat[1] = max(usubc_1.fxstat[1], *fx); + usubc_1.fxstat[2] = min(usubc_1.fxstat[2], *fx); + /* Computing MAX */ + d__1 = abs(usubc_1.fxstat[1]), d__2 = abs(usubc_1.fxstat[2]), d__1 = max(d__1, d__2); + fscale = max(d__1, 1.); + /* Computing 2nd power */ + d__1 = usubc_1.fxstat[3] / fscale; + /* Computing 2nd power */ + d__2 = (usubc_1.fxstat[0] - f1sv) / fscale; + /* Computing 2nd power */ + d__3 = (*fx - usubc_1.fxstat[0]) / fscale; + usubc_1.fxstat[3] = + fscale * sqrt(((nsv - 1) * (d__1 * d__1) + nsv * (d__2 * d__2) + *ifxwt * (d__3 * d__3)) / + (usubc_1.nfxe - 1)); + } + return 0; } /* fstats_ */ /* evalf.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ /* Common Block Declarations */ static struct { - doublereal fbonus, sfstop, sfbest; - logical new__; + doublereal fbonus, sfstop, sfbest; + logical new__; } isubc_; #define isubc_1 isubc_ @@ -1159,984 +1057,892 @@ static logical c_true = TRUE_; static logical c_false = FALSE_; -static int evalf_(D_fp f,void*fdata, integer *ns, integer *ips, doublereal *xs, - integer *n, doublereal *x, doublereal *sfx, integer *nfe) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - static integer i__; - static doublereal fx; - static logical newbst; - -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ - -/* evalf evaluates the function f at a point defined by x */ -/* with ns of its components replaced by those in xs. */ - -/* input */ - -/* f - user supplied function f(n,x) to be optimized */ - -/* ns - subspace dimension */ - -/* ips - permutation vector */ +static int evalf_(D_fp f, void *fdata, integer *ns, integer *ips, doublereal *xs, integer *n, + doublereal *x, doublereal *sfx, integer *nfe) { + /* System generated locals */ + integer i__1; -/* xs - double precision ns-vector to be mapped to x */ + /* Local variables */ + static integer i__; + static doublereal fx; + static logical newbst; -/* n - problem dimension */ + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ -/* x - double precision n-vector */ + /* evalf evaluates the function f at a point defined by x */ + /* with ns of its components replaced by those in xs. */ -/* nfe - number of function evaluations */ + /* input */ -/* output */ + /* f - user supplied function f(n,x) to be optimized */ -/* sfx - signed value of f evaluated at x */ + /* ns - subspace dimension */ -/* nfe - incremented number of function evaluations */ + /* ips - permutation vector */ -/* common */ + /* xs - double precision ns-vector to be mapped to x */ + /* n - problem dimension */ + /* x - double precision n-vector */ + /* nfe - number of function evaluations */ + /* output */ -/* local variables */ + /* sfx - signed value of f evaluated at x */ + /* nfe - incremented number of function evaluations */ + /* common */ -/* subroutines and functions */ + /* local variables */ + /* subroutines and functions */ -/* ----------------------------------------------------------- */ + /* ----------------------------------------------------------- */ - /* Parameter adjustments */ - --ips; - --xs; - --x; + /* Parameter adjustments */ + --ips; + --xs; + --x; - /* Function Body */ - i__1 = *ns; - for (i__ = 1; i__ <= i__1; ++i__) { - x[ips[i__]] = xs[i__]; -/* L10: */ + /* Function Body */ + i__1 = *ns; + for (i__ = 1; i__ <= i__1; ++i__) { + x[ips[i__]] = xs[i__]; + /* L10: */ + } + usubc_1.newx = isubc_1.new__ || usubc_1.irepl != 2; + fx = (*f)(*n, &x[1], fdata); + if (usubc_1.irepl == 0) { + if (usubc_1.minf) { *sfx = fx; } + else { + *sfx = -fx; } - usubc_1.newx = isubc_1.new__ || usubc_1.irepl != 2; - fx = (*f)(*n, &x[1], fdata); - if (usubc_1.irepl == 0) { - if (usubc_1.minf) { - *sfx = fx; - } else { - *sfx = -fx; - } - } else if (isubc_1.new__) { - if (usubc_1.minf) { - *sfx = fx; - newbst = fx < usubc_1.ftest; - } else { - *sfx = -fx; - newbst = fx > usubc_1.ftest; - } - if (usubc_1.initx || newbst) { - if (usubc_1.irepl == 1) { - fstats_(&fx, &c__1, &c_true); - } - usubc_1.ftest = fx; - isubc_1.sfbest = *sfx; - } - } else { - if (usubc_1.irepl == 1) { - fstats_(&fx, &c__1, &c_false); - fx = usubc_1.fxstat[usubc_1.ifxsw - 1]; - } - usubc_1.ftest = fx + isubc_1.fbonus * usubc_1.fxstat[3]; - if (usubc_1.minf) { - *sfx = usubc_1.ftest; - isubc_1.sfbest = fx; - } else { - *sfx = -usubc_1.ftest; - isubc_1.sfbest = -fx; - } + } + else if (isubc_1.new__) { + if (usubc_1.minf) { + *sfx = fx; + newbst = fx < usubc_1.ftest; } - ++(*nfe); - return 0; + else { + *sfx = -fx; + newbst = fx > usubc_1.ftest; + } + if (usubc_1.initx || newbst) { + if (usubc_1.irepl == 1) { fstats_(&fx, &c__1, &c_true); } + usubc_1.ftest = fx; + isubc_1.sfbest = *sfx; + } + } + else { + if (usubc_1.irepl == 1) { + fstats_(&fx, &c__1, &c_false); + fx = usubc_1.fxstat[usubc_1.ifxsw - 1]; + } + usubc_1.ftest = fx + isubc_1.fbonus * usubc_1.fxstat[3]; + if (usubc_1.minf) { + *sfx = usubc_1.ftest; + isubc_1.sfbest = fx; + } + else { + *sfx = -usubc_1.ftest; + isubc_1.sfbest = -fx; + } + } + ++(*nfe); + return 0; } /* evalf_ */ /* simplx.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int simplx_(D_fp f, void *fdata, integer *n, doublereal *step, integer * - ns, integer *ips, integer *maxnfe, logical *cmode, doublereal *x, - doublereal *fx, integer *nfe, doublereal *s, doublereal *fs, integer * - iflag) -{ - /* System generated locals */ - integer s_dim1, s_offset, i__1; - doublereal d__1, d__2; - - /* Local variables */ - static integer inew; - static integer npts; - static integer i__, j; - static integer icent; - static logical small; - static integer itemp; - static doublereal fc, fe; - static integer ih, il; - static doublereal fr; - static integer is; - static logical updatc; - static doublereal dum, tol; +static int simplx_(D_fp f, void *fdata, integer *n, doublereal *step, integer *ns, integer *ips, + integer *maxnfe, logical *cmode, doublereal *x, doublereal *fx, integer *nfe, + doublereal *s, doublereal *fs, integer *iflag) { + /* System generated locals */ + integer s_dim1, s_offset, i__1; + doublereal d__1, d__2; + /* Local variables */ + static integer inew; + static integer npts; + static integer i__, j; + static integer icent; + static logical small; + static integer itemp; + static doublereal fc, fe; + static integer ih, il; + static doublereal fr; + static integer is; + static logical updatc; + static doublereal dum, tol; + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ + /* simplx uses the Nelder-Mead simplex method to minimize the */ + /* function f on a subspace. */ -/* simplx uses the Nelder-Mead simplex method to minimize the */ -/* function f on a subspace. */ + /* input */ -/* input */ + /* f - function to be minimized, declared external in */ + /* calling routine */ -/* f - function to be minimized, declared external in */ -/* calling routine */ + /* n - problem dimension */ -/* n - problem dimension */ + /* step - stepsizes for corresponding components of x */ -/* step - stepsizes for corresponding components of x */ + /* ns - subspace dimension */ -/* ns - subspace dimension */ + /* ips - permutation vector */ -/* ips - permutation vector */ + /* maxnfe - maximum number of function evaluations */ -/* maxnfe - maximum number of function evaluations */ + /* cmode - logical switch */ + /* = .true. : continuation of previous call */ + /* = .false. : first call */ -/* cmode - logical switch */ -/* = .true. : continuation of previous call */ -/* = .false. : first call */ + /* x - starting guess for minimum */ -/* x - starting guess for minimum */ + /* fx - value of f at x */ -/* fx - value of f at x */ + /* nfe - number of function evaluations */ -/* nfe - number of function evaluations */ + /* s - double precision work array of dimension .ge. */ + /* ns*(ns+3) used to store simplex */ -/* s - double precision work array of dimension .ge. */ -/* ns*(ns+3) used to store simplex */ + /* fs - double precision work array of dimension .ge. */ + /* ns+1 used to store function values of simplex */ + /* vertices */ -/* fs - double precision work array of dimension .ge. */ -/* ns+1 used to store function values of simplex */ -/* vertices */ + /* output */ -/* output */ + /* x - computed minimum */ -/* x - computed minimum */ + /* fx - value of f at x */ -/* fx - value of f at x */ + /* nfe - incremented number of function evaluations */ -/* nfe - incremented number of function evaluations */ + /* iflag - error flag */ + /* = -1 : maxnfe exceeded */ + /* = 0 : simplex reduced by factor of psi */ + /* = 1 : limit of machine precision */ + /* = 2 : reached fstop */ -/* iflag - error flag */ -/* = -1 : maxnfe exceeded */ -/* = 0 : simplex reduced by factor of psi */ -/* = 1 : limit of machine precision */ -/* = 2 : reached fstop */ + /* common */ -/* common */ + /* local variables */ + /* subroutines and functions */ + /* blas */ + /* fortran */ + /* ----------------------------------------------------------- */ + /* Parameter adjustments */ + --x; + --step; + --fs; + s_dim1 = *ns; + s_offset = 1 + s_dim1 * 1; + s -= s_offset; + --ips; -/* local variables */ - - - -/* subroutines and functions */ - -/* blas */ -/* fortran */ - -/* ----------------------------------------------------------- */ - - /* Parameter adjustments */ - --x; - --step; - --fs; - s_dim1 = *ns; - s_offset = 1 + s_dim1 * 1; - s -= s_offset; - --ips; - - /* Function Body */ - if (*cmode) { - goto L50; - } - npts = *ns + 1; - icent = *ns + 2; - itemp = *ns + 3; - updatc = FALSE_; - start_(n, &x[1], &step[1], ns, &ips[1], &s[s_offset], &small); - if (small) { - *iflag = 1; - return 0; - } - if (usubc_1.irepl > 0) { - isubc_1.new__ = FALSE_; - evalf_((D_fp)f,fdata, ns, &ips[1], &s[s_dim1 + 1], n, &x[1], &fs[1], nfe); - } else { - fs[1] = *fx; - } - isubc_1.new__ = TRUE_; - i__1 = npts; - for (j = 2; j <= i__1; ++j) { - evalf_((D_fp)f, fdata,ns, &ips[1], &s[j * s_dim1 + 1], n, &x[1], &fs[j], - nfe); -/* L10: */ - } - il = 1; - order_(&npts, &fs[1], &il, &is, &ih); - tol = usubc_1.psi * dist_(ns, &s[ih * s_dim1 + 1], &s[il * s_dim1 + 1]); + /* Function Body */ + if (*cmode) { goto L50; } + npts = *ns + 1; + icent = *ns + 2; + itemp = *ns + 3; + updatc = FALSE_; + start_(n, &x[1], &step[1], ns, &ips[1], &s[s_offset], &small); + if (small) { + *iflag = 1; + return 0; + } + if (usubc_1.irepl > 0) { + isubc_1.new__ = FALSE_; + evalf_((D_fp)f, fdata, ns, &ips[1], &s[s_dim1 + 1], n, &x[1], &fs[1], nfe); + } + else { + fs[1] = *fx; + } + isubc_1.new__ = TRUE_; + i__1 = npts; + for (j = 2; j <= i__1; ++j) { + evalf_((D_fp)f, fdata, ns, &ips[1], &s[j * s_dim1 + 1], n, &x[1], &fs[j], nfe); + /* L10: */ + } + il = 1; + order_(&npts, &fs[1], &il, &is, &ih); + tol = usubc_1.psi * dist_(ns, &s[ih * s_dim1 + 1], &s[il * s_dim1 + 1]); -/* main loop */ + /* main loop */ L20: - calcc_(ns, &s[s_offset], &ih, &inew, &updatc, &s[icent * s_dim1 + 1]); - updatc = TRUE_; - inew = ih; - -/* reflect */ - - newpt_(ns, &usubc_1.alpha, &s[icent * s_dim1 + 1], &s[ih * s_dim1 + 1], & - c_true, &s[itemp * s_dim1 + 1], &small); - if (small) { - goto L40; - } - evalf_((D_fp)f,fdata, ns, &ips[1], &s[itemp * s_dim1 + 1], n, &x[1], &fr, nfe); - if (fr < fs[il]) { - -/* expand */ - - d__1 = -usubc_1.gamma; - newpt_(ns, &d__1, &s[icent * s_dim1 + 1], &s[itemp * s_dim1 + 1], & - c_true, &s[ih * s_dim1 + 1], &small); - if (small) { - goto L40; - } - evalf_((D_fp)f,fdata, ns, &ips[1], &s[ih * s_dim1 + 1], n, &x[1], &fe, nfe); - if (fe < fr) { - fs[ih] = fe; - } else { - dcopy_(ns, &s[itemp * s_dim1 + 1], &c__1, &s[ih * s_dim1 + 1], & - c__1); - fs[ih] = fr; - } - } else if (fr < fs[is]) { - -/* accept reflected point */ - - dcopy_(ns, &s[itemp * s_dim1 + 1], &c__1, &s[ih * s_dim1 + 1], &c__1); - fs[ih] = fr; - } else { - -/* contract */ - - if (fr > fs[ih]) { - d__1 = -usubc_1.beta; - newpt_(ns, &d__1, &s[icent * s_dim1 + 1], &s[ih * s_dim1 + 1], & - c_true, &s[itemp * s_dim1 + 1], &small); - } else { - d__1 = -usubc_1.beta; - newpt_(ns, &d__1, &s[icent * s_dim1 + 1], &s[itemp * s_dim1 + 1], - &c_false, &dum, &small); - } - if (small) { - goto L40; - } - evalf_((D_fp)f,fdata, ns, &ips[1], &s[itemp * s_dim1 + 1], n, &x[1], &fc, - nfe); -/* Computing MIN */ - d__1 = fr, d__2 = fs[ih]; - if (fc < min(d__1,d__2)) { - dcopy_(ns, &s[itemp * s_dim1 + 1], &c__1, &s[ih * s_dim1 + 1], & - c__1); - fs[ih] = fc; - } else { - -/* shrink simplex */ - - i__1 = npts; - for (j = 1; j <= i__1; ++j) { - if (j != il) { - d__1 = -usubc_1.delta; - newpt_(ns, &d__1, &s[il * s_dim1 + 1], &s[j * s_dim1 + 1], - &c_false, &dum, &small); - if (small) { - goto L40; - } - evalf_((D_fp)f,fdata, ns, &ips[1], &s[j * s_dim1 + 1], n, &x[1], - &fs[j], nfe); - } -/* L30: */ - } - } - updatc = FALSE_; + calcc_(ns, &s[s_offset], &ih, &inew, &updatc, &s[icent * s_dim1 + 1]); + updatc = TRUE_; + inew = ih; + + /* reflect */ + + newpt_(ns, &usubc_1.alpha, &s[icent * s_dim1 + 1], &s[ih * s_dim1 + 1], &c_true, + &s[itemp * s_dim1 + 1], &small); + if (small) { goto L40; } + evalf_((D_fp)f, fdata, ns, &ips[1], &s[itemp * s_dim1 + 1], n, &x[1], &fr, nfe); + if (fr < fs[il]) { + + /* expand */ + + d__1 = -usubc_1.gamma; + newpt_(ns, &d__1, &s[icent * s_dim1 + 1], &s[itemp * s_dim1 + 1], &c_true, &s[ih * s_dim1 + 1], + &small); + if (small) { goto L40; } + evalf_((D_fp)f, fdata, ns, &ips[1], &s[ih * s_dim1 + 1], n, &x[1], &fe, nfe); + if (fe < fr) { fs[ih] = fe; } + else { + dcopy_(ns, &s[itemp * s_dim1 + 1], &c__1, &s[ih * s_dim1 + 1], &c__1); + fs[ih] = fr; + } + } + else if (fr < fs[is]) { + + /* accept reflected point */ + + dcopy_(ns, &s[itemp * s_dim1 + 1], &c__1, &s[ih * s_dim1 + 1], &c__1); + fs[ih] = fr; + } + else { + + /* contract */ + + if (fr > fs[ih]) { + d__1 = -usubc_1.beta; + newpt_(ns, &d__1, &s[icent * s_dim1 + 1], &s[ih * s_dim1 + 1], &c_true, + &s[itemp * s_dim1 + 1], &small); + } + else { + d__1 = -usubc_1.beta; + newpt_(ns, &d__1, &s[icent * s_dim1 + 1], &s[itemp * s_dim1 + 1], &c_false, &dum, &small); + } + if (small) { goto L40; } + evalf_((D_fp)f, fdata, ns, &ips[1], &s[itemp * s_dim1 + 1], n, &x[1], &fc, nfe); + /* Computing MIN */ + d__1 = fr, d__2 = fs[ih]; + if (fc < min(d__1, d__2)) { + dcopy_(ns, &s[itemp * s_dim1 + 1], &c__1, &s[ih * s_dim1 + 1], &c__1); + fs[ih] = fc; + } + else { + + /* shrink simplex */ + + i__1 = npts; + for (j = 1; j <= i__1; ++j) { + if (j != il) { + d__1 = -usubc_1.delta; + newpt_(ns, &d__1, &s[il * s_dim1 + 1], &s[j * s_dim1 + 1], &c_false, &dum, &small); + if (small) { goto L40; } + evalf_((D_fp)f, fdata, ns, &ips[1], &s[j * s_dim1 + 1], n, &x[1], &fs[j], nfe); + } + /* L30: */ + } } - order_(&npts, &fs[1], &il, &is, &ih); + updatc = FALSE_; + } + order_(&npts, &fs[1], &il, &is, &ih); -/* check termination */ + /* check termination */ L40: - if (usubc_1.irepl == 0) { - *fx = fs[il]; - } else { - *fx = isubc_1.sfbest; - } + if (usubc_1.irepl == 0) { *fx = fs[il]; } + else { + *fx = isubc_1.sfbest; + } L50: - if (usubc_1.nfstop > 0 && *fx <= isubc_1.sfstop && usubc_1.nfxe >= - usubc_1.nfstop) { - *iflag = 2; - } else if (*nfe >= *maxnfe) { - *iflag = -1; - } else if (dist_(ns, &s[ih * s_dim1 + 1], &s[il * s_dim1 + 1]) <= tol || - small) { - *iflag = 0; - } else { - goto L20; - } - -/* end main loop, return best point */ - - i__1 = *ns; - for (i__ = 1; i__ <= i__1; ++i__) { - x[ips[i__]] = s[i__ + il * s_dim1]; -/* L60: */ - } - return 0; + if (usubc_1.nfstop > 0 && *fx <= isubc_1.sfstop && usubc_1.nfxe >= usubc_1.nfstop) { *iflag = 2; } + else if (*nfe >= *maxnfe) { + *iflag = -1; + } + else if (dist_(ns, &s[ih * s_dim1 + 1], &s[il * s_dim1 + 1]) <= tol || small) { + *iflag = 0; + } + else { + goto L20; + } + + /* end main loop, return best point */ + + i__1 = *ns; + for (i__ = 1; i__ <= i__1; ++i__) { + x[ips[i__]] = s[i__ + il * s_dim1]; + /* L60: */ + } + return 0; } /* simplx_ */ /* subopt.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int subopt_(integer *n) -{ - - -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ - -/* subopt sets options for subplx. */ +static int subopt_(integer *n) { -/* input */ + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ -/* n - problem dimension */ + /* subopt sets options for subplx. */ -/* common */ + /* input */ + /* n - problem dimension */ + /* common */ + /* subroutines and functions */ -/* subroutines and functions */ + /* fortran */ -/* fortran */ + /* ----------------------------------------------------------- */ -/* ----------------------------------------------------------- */ + /* *********************************************************** */ + /* simplex method strategy parameters */ + /* *********************************************************** */ -/* *********************************************************** */ -/* simplex method strategy parameters */ -/* *********************************************************** */ + /* alpha - reflection coefficient */ + /* alpha .gt. 0 */ -/* alpha - reflection coefficient */ -/* alpha .gt. 0 */ + usubc_1.alpha = 1.; - usubc_1.alpha = 1.; + /* beta - contraction coefficient */ + /* 0 .lt. beta .lt. 1 */ -/* beta - contraction coefficient */ -/* 0 .lt. beta .lt. 1 */ + usubc_1.beta = .5; - usubc_1.beta = .5; + /* gamma - expansion coefficient */ + /* gamma .gt. 1 */ -/* gamma - expansion coefficient */ -/* gamma .gt. 1 */ + usubc_1.gamma = 2.; - usubc_1.gamma = 2.; + /* delta - shrinkage (massive contraction) coefficient */ + /* 0 .lt. delta .lt. 1 */ -/* delta - shrinkage (massive contraction) coefficient */ -/* 0 .lt. delta .lt. 1 */ + usubc_1.delta = .5; - usubc_1.delta = .5; + /* *********************************************************** */ + /* subplex method strategy parameters */ + /* *********************************************************** */ -/* *********************************************************** */ -/* subplex method strategy parameters */ -/* *********************************************************** */ + /* psi - simplex reduction coefficient */ + /* 0 .lt. psi .lt. 1 */ -/* psi - simplex reduction coefficient */ -/* 0 .lt. psi .lt. 1 */ + usubc_1.psi = .25; - usubc_1.psi = .25; + /* omega - step reduction coefficient */ + /* 0 .lt. omega .lt. 1 */ -/* omega - step reduction coefficient */ -/* 0 .lt. omega .lt. 1 */ + usubc_1.omega = .1; - usubc_1.omega = .1; + /* nsmin and nsmax specify a range of subspace dimensions. */ + /* In addition to satisfying 1 .le. nsmin .le. nsmax .le. n, */ + /* nsmin and nsmax must be chosen so that n can be expressed */ + /* as a sum of positive integers where each of these integers */ + /* ns(i) satisfies nsmin .le. ns(i) .ge. nsmax. */ + /* Specifically, */ + /* nsmin*ceil(n/nsmax) .le. n must be true. */ -/* nsmin and nsmax specify a range of subspace dimensions. */ -/* In addition to satisfying 1 .le. nsmin .le. nsmax .le. n, */ -/* nsmin and nsmax must be chosen so that n can be expressed */ -/* as a sum of positive integers where each of these integers */ -/* ns(i) satisfies nsmin .le. ns(i) .ge. nsmax. */ -/* Specifically, */ -/* nsmin*ceil(n/nsmax) .le. n must be true. */ + /* nsmin - subspace dimension minimum */ -/* nsmin - subspace dimension minimum */ + usubc_1.nsmin = min(2, *n); - usubc_1.nsmin = min(2,*n); + /* nsmax - subspace dimension maximum */ -/* nsmax - subspace dimension maximum */ + usubc_1.nsmax = min(5, *n); - usubc_1.nsmax = min(5,*n); + /* *********************************************************** */ + /* subplex method special cases */ + /* *********************************************************** */ + /* nelder-mead simplex method with periodic restarts */ + /* nsmin = nsmax = n */ + /* *********************************************************** */ + /* nelder-mead simplex method */ + /* nsmin = nsmax = n, psi = small positive */ + /* *********************************************************** */ -/* *********************************************************** */ -/* subplex method special cases */ -/* *********************************************************** */ -/* nelder-mead simplex method with periodic restarts */ -/* nsmin = nsmax = n */ -/* *********************************************************** */ -/* nelder-mead simplex method */ -/* nsmin = nsmax = n, psi = small positive */ -/* *********************************************************** */ + /* irepl, ifxsw, and bonus deal with measurement replication. */ + /* Objective functions subject to large amounts of noise can */ + /* cause an optimization method to halt at a false optimum. */ + /* An expensive solution to this problem is to evaluate f */ + /* several times at each point and return the average (or max */ + /* or min) of these trials as the function value. subplx */ + /* performs measurement replication only at the current best */ + /* point. The longer a point is retained as best, the more */ + /* accurate its function value becomes. */ -/* irepl, ifxsw, and bonus deal with measurement replication. */ -/* Objective functions subject to large amounts of noise can */ -/* cause an optimization method to halt at a false optimum. */ -/* An expensive solution to this problem is to evaluate f */ -/* several times at each point and return the average (or max */ -/* or min) of these trials as the function value. subplx */ -/* performs measurement replication only at the current best */ -/* point. The longer a point is retained as best, the more */ -/* accurate its function value becomes. */ + /* The common variable nfxe contains the number of function */ + /* evaluations at the current best point. fxstat contains the */ + /* mean, max, min, and standard deviation of these trials. */ -/* The common variable nfxe contains the number of function */ -/* evaluations at the current best point. fxstat contains the */ -/* mean, max, min, and standard deviation of these trials. */ + /* irepl - measurement replication switch */ + /* irepl = 0, 1, or 2 */ + /* = 0 : no measurement replication */ + /* = 1 : subplx performs measurement replication */ + /* = 2 : user performs measurement replication */ + /* (This is useful when optimizing on the mean, */ + /* max, or min of trials is insufficient. Common */ + /* variable initx is true for first function */ + /* evaluation. newx is true for first trial at */ + /* this point. The user uses subroutine fstats */ + /* within his objective function to maintain */ + /* fxstat. By monitoring newx, the user can tell */ + /* whether to return the function evaluation */ + /* (newx = .true.) or to use the new function */ + /* evaluation to refine the function evaluation */ + /* of the current best point (newx = .false.). */ + /* The common variable ftest gives the function */ + /* value that a new point must beat to be */ + /* considered the new best point.) */ -/* irepl - measurement replication switch */ -/* irepl = 0, 1, or 2 */ -/* = 0 : no measurement replication */ -/* = 1 : subplx performs measurement replication */ -/* = 2 : user performs measurement replication */ -/* (This is useful when optimizing on the mean, */ -/* max, or min of trials is insufficient. Common */ -/* variable initx is true for first function */ -/* evaluation. newx is true for first trial at */ -/* this point. The user uses subroutine fstats */ -/* within his objective function to maintain */ -/* fxstat. By monitoring newx, the user can tell */ -/* whether to return the function evaluation */ -/* (newx = .true.) or to use the new function */ -/* evaluation to refine the function evaluation */ -/* of the current best point (newx = .false.). */ -/* The common variable ftest gives the function */ -/* value that a new point must beat to be */ -/* considered the new best point.) */ + usubc_1.irepl = 0; - usubc_1.irepl = 0; + /* ifxsw - measurement replication optimization switch */ + /* ifxsw = 1, 2, or 3 */ + /* = 1 : retain mean of trials as best function value */ + /* = 2 : retain max */ + /* = 3 : retain min */ -/* ifxsw - measurement replication optimization switch */ -/* ifxsw = 1, 2, or 3 */ -/* = 1 : retain mean of trials as best function value */ -/* = 2 : retain max */ -/* = 3 : retain min */ + usubc_1.ifxsw = 1; - usubc_1.ifxsw = 1; + /* Since the current best point will also be the most */ + /* accurately evaluated point whenever irepl .gt. 0, a bonus */ + /* should be added to the function value of the best point */ + /* so that the best point is not replaced by a new point */ + /* that only appears better because of noise. */ + /* subplx uses bonus to determine how many multiples of */ + /* fxstat(4) should be added as a bonus to the function */ + /* evaluation. (The bonus is adjusted automatically by */ + /* subplx when ifxsw or minf is changed.) */ -/* Since the current best point will also be the most */ -/* accurately evaluated point whenever irepl .gt. 0, a bonus */ -/* should be added to the function value of the best point */ -/* so that the best point is not replaced by a new point */ -/* that only appears better because of noise. */ -/* subplx uses bonus to determine how many multiples of */ -/* fxstat(4) should be added as a bonus to the function */ -/* evaluation. (The bonus is adjusted automatically by */ -/* subplx when ifxsw or minf is changed.) */ + /* bonus - measurement replication bonus coefficient */ + /* bonus .ge. 0 (normally, bonus = 0 or 1) */ + /* = 0 : bonus not used */ + /* = 1 : bonus used */ -/* bonus - measurement replication bonus coefficient */ -/* bonus .ge. 0 (normally, bonus = 0 or 1) */ -/* = 0 : bonus not used */ -/* = 1 : bonus used */ + usubc_1.bonus = 1.; - usubc_1.bonus = 1.; + /* nfstop = 0 : f(x) is not tested against fstop */ + /* = 1 : if f(x) has reached fstop, subplx returns */ + /* iflag = 2 */ + /* = 2 : (only valid when irepl .gt. 0) */ + /* if f(x) has reached fstop and */ + /* nfxe .gt. nfstop, subplx returns iflag = 2 */ -/* nfstop = 0 : f(x) is not tested against fstop */ -/* = 1 : if f(x) has reached fstop, subplx returns */ -/* iflag = 2 */ -/* = 2 : (only valid when irepl .gt. 0) */ -/* if f(x) has reached fstop and */ -/* nfxe .gt. nfstop, subplx returns iflag = 2 */ + usubc_1.nfstop = 0; - usubc_1.nfstop = 0; + /* fstop - f target value */ + /* Its usage is determined by the value of nfstop. */ -/* fstop - f target value */ -/* Its usage is determined by the value of nfstop. */ + /* minf - logical switch */ + /* = .true. : subplx performs minimization */ + /* = .false. : subplx performs maximization */ -/* minf - logical switch */ -/* = .true. : subplx performs minimization */ -/* = .false. : subplx performs maximization */ - - usubc_1.minf = TRUE_; - return 0; + usubc_1.minf = TRUE_; + return 0; } /* subopt_ */ /* setstp.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static double d_sign(doublereal *x, doublereal *y) -{ - return copysign(*x, *y); -} - -static int setstp_(integer *nsubs, integer *n, doublereal *deltax, - doublereal *step) -{ - /* System generated locals */ - integer i__1; - doublereal d__1, d__2, d__3; +static double d_sign(doublereal *x, doublereal *y) { return copysign(*x, *y); } - /* Builtin functions */ -/* double d_sign(doublereal *, doublereal *); */ +static int setstp_(integer *nsubs, integer *n, doublereal *deltax, doublereal *step) { + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3; - /* Local variables */ - static integer i__; - static doublereal stpfac; + /* Builtin functions */ + /* double d_sign(doublereal *, doublereal *); */ + /* Local variables */ + static integer i__; + static doublereal stpfac; + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ + /* setstp sets the stepsizes for the corresponding components */ + /* of the solution vector. */ -/* setstp sets the stepsizes for the corresponding components */ -/* of the solution vector. */ + /* input */ -/* input */ + /* nsubs - number of subspaces */ -/* nsubs - number of subspaces */ + /* n - number of components (problem dimension) */ -/* n - number of components (problem dimension) */ + /* deltax - vector of change in solution vector */ -/* deltax - vector of change in solution vector */ + /* step - stepsizes for corresponding components of */ + /* solution vector */ -/* step - stepsizes for corresponding components of */ -/* solution vector */ + /* output */ -/* output */ + /* step - new stepsizes */ -/* step - new stepsizes */ + /* common */ -/* common */ + /* local variables */ + /* subroutines and functions */ + /* blas */ + /* fortran */ -/* local variables */ + /* ----------------------------------------------------------- */ + /* set new step */ + /* Parameter adjustments */ + --step; + --deltax; -/* subroutines and functions */ + /* Function Body */ + if (*nsubs > 1) { + /* Computing MIN */ + /* Computing MAX */ + d__3 = dasum_(n, &deltax[1], &c__1) / dasum_(n, &step[1], &c__1); + d__1 = max(d__3, usubc_1.omega), d__2 = 1. / usubc_1.omega; + stpfac = min(d__1, d__2); + } + else { + stpfac = usubc_1.psi; + } + dscal_(n, &stpfac, &step[1], &c__1); -/* blas */ -/* fortran */ + /* reorient simplex */ -/* ----------------------------------------------------------- */ - -/* set new step */ - - /* Parameter adjustments */ - --step; - --deltax; - - /* Function Body */ - if (*nsubs > 1) { -/* Computing MIN */ -/* Computing MAX */ - d__3 = dasum_(n, &deltax[1], &c__1) / dasum_(n, &step[1], &c__1); - d__1 = max(d__3,usubc_1.omega), d__2 = 1. / usubc_1.omega; - stpfac = min(d__1,d__2); - } else { - stpfac = usubc_1.psi; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (deltax[i__] != 0.) { step[i__] = d_sign(&step[i__], &deltax[i__]); } + else { + step[i__] = -step[i__]; } - dscal_(n, &stpfac, &step[1], &c__1); - -/* reorient simplex */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (deltax[i__] != 0.) { - step[i__] = d_sign(&step[i__], &deltax[i__]); - } else { - step[i__] = -step[i__]; - } -/* L10: */ - } - return 0; + /* L10: */ + } + return 0; } /* setstp_ */ /* subplx.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: - -lf2c -lm (in that order) + -lf2c -lm (in that order) */ -static int subplx_(D_fp f, void *fdata, integer *n, doublereal *tol, integer * - maxnfe, integer *mode, doublereal *scale, doublereal *x, doublereal * - fx, integer *nfe, doublereal *work, integer *iwork, integer *iflag) -{ - /* Initialized data */ - - static doublereal bnsfac[6] /* was [3][2] */ = { -1.,-2.,0.,1.,0.,2. }; - - /* System generated locals */ - integer i__1; - doublereal d__1, d__2, d__3, d__4, d__5, d__6; - - /* Local variables */ - static integer i__; - static logical cmode; - static integer istep; - static doublereal xpscl; - static integer nsubs, ipptr; - static integer isptr; - static integer ns, insfnl, ifsptr; - static integer insptr; - static integer istptr; - static doublereal scl, dum; - static integer ins; - static doublereal sfx; - - - -/* Coded by Tom Rowan */ -/* Department of Computer Sciences */ -/* University of Texas at Austin */ - -/* subplx uses the subplex method to solve unconstrained */ -/* optimization problems. The method is well suited for */ -/* optimizing objective functions that are noisy or are */ -/* discontinuous at the solution. */ - -/* subplx sets default optimization options by calling the */ -/* subroutine subopt. The user can override these defaults */ -/* by calling subopt prior to calling subplx, changing the */ -/* appropriate common variables, and setting the value of */ -/* mode as indicated below. */ - -/* By default, subplx performs minimization. */ - -/* input */ - -/* f - user supplied function f(n,x) to be optimized, */ -/* declared external in calling routine */ - -/* n - problem dimension */ - -/* tol - relative error tolerance for x (tol .ge. 0.) */ - -/* maxnfe - maximum number of function evaluations */ - -/* mode - integer mode switch with binary expansion */ -/* (bit 1) (bit 0) : */ -/* bit 0 = 0 : first call to subplx */ -/* = 1 : continuation of previous call */ -/* bit 1 = 0 : use default options */ -/* = 1 : user set options */ - -/* scale - scale and initial stepsizes for corresponding */ -/* components of x */ -/* (If scale(1) .lt. 0., */ -/* abs(scale(1)) is used for all components of x, */ -/* and scale(2),...,scale(n) are not referenced.) */ - -/* x - starting guess for optimum */ - -/* work - double precision work array of dimension .ge. */ -/* 2*n + nsmax*(nsmax+4) + 1 */ -/* (nsmax is set in subroutine subopt. */ -/* default: nsmax = min(5,n)) */ - -/* iwork - integer work array of dimension .ge. */ -/* n + int(n/nsmin) */ -/* (nsmin is set in subroutine subopt. */ -/* default: nsmin = min(2,n)) */ - -/* output */ - -/* x - computed optimum */ - -/* fx - value of f at x */ - -/* nfe - number of function evaluations */ - -/* iflag - error flag */ -/* = -2 : invalid input */ -/* = -1 : maxnfe exceeded */ -/* = 0 : tol satisfied */ -/* = 1 : limit of machine precision */ -/* = 2 : fstop reached (fstop usage is determined */ -/* by values of options minf, nfstop, and */ -/* irepl. default: f(x) not tested against */ -/* fstop) */ -/* iflag should not be reset between calls to */ -/* subplx. */ - -/* common */ - - - - - -/* local variables */ - - - -/* subroutines and functions */ - -/* blas */ -/* fortran */ - -/* data */ - - /* Parameter adjustments */ - --x; - --scale; - --work; - --iwork; - - /* Function Body */ -/* ----------------------------------------------------------- */ - - if (*mode % 2 == 0) { - -/* first call, check input */ - - if (*n < 1) { - goto L120; - } - if (*tol < 0.) { - goto L120; - } - if (*maxnfe < 1) { - goto L120; - } - if (scale[1] >= 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - xpscl = x[i__] + scale[i__]; - if (xpscl == x[i__]) { - goto L120; - } -/* L10: */ - } - } else { - scl = abs(scale[1]); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - xpscl = x[i__] + scl; - if (xpscl == x[i__]) { - goto L120; - } -/* L20: */ - } - } - if (*mode / 2 % 2 == 0) { - subopt_(n); - } else { - if (usubc_1.alpha <= 0.) { - goto L120; - } - if (usubc_1.beta <= 0. || usubc_1.beta >= 1.) { - goto L120; - } - if (usubc_1.gamma <= 1.) { - goto L120; - } - if (usubc_1.delta <= 0. || usubc_1.delta >= 1.) { - goto L120; - } - if (usubc_1.psi <= 0. || usubc_1.psi >= 1.) { - goto L120; - } - if (usubc_1.omega <= 0. || usubc_1.omega >= 1.) { - goto L120; - } - if (usubc_1.nsmin < 1 || usubc_1.nsmax < usubc_1.nsmin || *n < - usubc_1.nsmax) { - goto L120; - } - if (*n < ((*n - 1) / usubc_1.nsmax + 1) * usubc_1.nsmin) { - goto L120; - } - if (usubc_1.irepl < 0 || usubc_1.irepl > 2) { - goto L120; - } - if (usubc_1.ifxsw < 1 || usubc_1.ifxsw > 3) { - goto L120; - } - if (usubc_1.bonus < 0.) { - goto L120; - } - if (usubc_1.nfstop < 0) { - goto L120; - } - } - -/* initialization */ - - istptr = *n + 1; - isptr = istptr + *n; - ifsptr = isptr + usubc_1.nsmax * (usubc_1.nsmax + 3); - insptr = *n + 1; - if (scale[1] > 0.) { - dcopy_(n, &scale[1], &c__1, &work[1], &c__1); - dcopy_(n, &scale[1], &c__1, &work[istptr], &c__1); - } else { - dcopy_(n, &scl, &c__0, &work[1], &c__1); - dcopy_(n, &scl, &c__0, &work[istptr], &c__1); - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - iwork[i__] = i__; -/* L30: */ - } - *nfe = 0; - usubc_1.nfxe = 1; - if (usubc_1.irepl == 0) { - isubc_1.fbonus = 0.; - } else if (usubc_1.minf) { - isubc_1.fbonus = bnsfac[usubc_1.ifxsw - 1] * usubc_1.bonus; - } else { - isubc_1.fbonus = bnsfac[usubc_1.ifxsw + 2] * usubc_1.bonus; - } - if (usubc_1.nfstop == 0) { - isubc_1.sfstop = 0.; - } else if (usubc_1.minf) { - isubc_1.sfstop = usubc_1.fstop; - } else { - isubc_1.sfstop = -usubc_1.fstop; - } - usubc_1.ftest = 0.; - cmode = FALSE_; - isubc_1.new__ = TRUE_; - usubc_1.initx = TRUE_; - evalf_((D_fp)f, fdata, &c__0, &iwork[1], &dum, n, &x[1], &sfx, nfe); - usubc_1.initx = FALSE_; - } else { - -/* continuation of previous call */ - - if (*iflag == 2) { - if (usubc_1.minf) { - isubc_1.sfstop = usubc_1.fstop; - } else { - isubc_1.sfstop = -usubc_1.fstop; - } - cmode = TRUE_; - goto L70; - } else if (*iflag == -1) { - cmode = TRUE_; - goto L70; - } else if (*iflag == 0) { - cmode = FALSE_; - goto L90; - } else { - return 0; - } +static int subplx_(D_fp f, void *fdata, integer *n, doublereal *tol, integer *maxnfe, integer *mode, + doublereal *scale, doublereal *x, doublereal *fx, integer *nfe, doublereal *work, + integer *iwork, integer *iflag) { + /* Initialized data */ + + static doublereal bnsfac[6] /* was [3][2] */ = {-1., -2., 0., 1., 0., 2.}; + + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + static integer i__; + static logical cmode; + static integer istep; + static doublereal xpscl; + static integer nsubs, ipptr; + static integer isptr; + static integer ns, insfnl, ifsptr; + static integer insptr; + static integer istptr; + static doublereal scl, dum; + static integer ins; + static doublereal sfx; + + /* Coded by Tom Rowan */ + /* Department of Computer Sciences */ + /* University of Texas at Austin */ + + /* subplx uses the subplex method to solve unconstrained */ + /* optimization problems. The method is well suited for */ + /* optimizing objective functions that are noisy or are */ + /* discontinuous at the solution. */ + + /* subplx sets default optimization options by calling the */ + /* subroutine subopt. The user can override these defaults */ + /* by calling subopt prior to calling subplx, changing the */ + /* appropriate common variables, and setting the value of */ + /* mode as indicated below. */ + + /* By default, subplx performs minimization. */ + + /* input */ + + /* f - user supplied function f(n,x) to be optimized, */ + /* declared external in calling routine */ + + /* n - problem dimension */ + + /* tol - relative error tolerance for x (tol .ge. 0.) */ + + /* maxnfe - maximum number of function evaluations */ + + /* mode - integer mode switch with binary expansion */ + /* (bit 1) (bit 0) : */ + /* bit 0 = 0 : first call to subplx */ + /* = 1 : continuation of previous call */ + /* bit 1 = 0 : use default options */ + /* = 1 : user set options */ + + /* scale - scale and initial stepsizes for corresponding */ + /* components of x */ + /* (If scale(1) .lt. 0., */ + /* abs(scale(1)) is used for all components of x, */ + /* and scale(2),...,scale(n) are not referenced.) */ + + /* x - starting guess for optimum */ + + /* work - double precision work array of dimension .ge. */ + /* 2*n + nsmax*(nsmax+4) + 1 */ + /* (nsmax is set in subroutine subopt. */ + /* default: nsmax = min(5,n)) */ + + /* iwork - integer work array of dimension .ge. */ + /* n + int(n/nsmin) */ + /* (nsmin is set in subroutine subopt. */ + /* default: nsmin = min(2,n)) */ + + /* output */ + + /* x - computed optimum */ + + /* fx - value of f at x */ + + /* nfe - number of function evaluations */ + + /* iflag - error flag */ + /* = -2 : invalid input */ + /* = -1 : maxnfe exceeded */ + /* = 0 : tol satisfied */ + /* = 1 : limit of machine precision */ + /* = 2 : fstop reached (fstop usage is determined */ + /* by values of options minf, nfstop, and */ + /* irepl. default: f(x) not tested against */ + /* fstop) */ + /* iflag should not be reset between calls to */ + /* subplx. */ + + /* common */ + + /* local variables */ + + /* subroutines and functions */ + + /* blas */ + /* fortran */ + + /* data */ + + /* Parameter adjustments */ + --x; + --scale; + --work; + --iwork; + + /* Function Body */ + /* ----------------------------------------------------------- */ + + if (*mode % 2 == 0) { + + /* first call, check input */ + + if (*n < 1) { goto L120; } + if (*tol < 0.) { goto L120; } + if (*maxnfe < 1) { goto L120; } + if (scale[1] >= 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + xpscl = x[i__] + scale[i__]; + if (xpscl == x[i__]) { goto L120; } + /* L10: */ + } + } + else { + scl = abs(scale[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + xpscl = x[i__] + scl; + if (xpscl == x[i__]) { goto L120; } + /* L20: */ + } + } + if (*mode / 2 % 2 == 0) { subopt_(n); } + else { + if (usubc_1.alpha <= 0.) { goto L120; } + if (usubc_1.beta <= 0. || usubc_1.beta >= 1.) { goto L120; } + if (usubc_1.gamma <= 1.) { goto L120; } + if (usubc_1.delta <= 0. || usubc_1.delta >= 1.) { goto L120; } + if (usubc_1.psi <= 0. || usubc_1.psi >= 1.) { goto L120; } + if (usubc_1.omega <= 0. || usubc_1.omega >= 1.) { goto L120; } + if (usubc_1.nsmin < 1 || usubc_1.nsmax < usubc_1.nsmin || *n < usubc_1.nsmax) { goto L120; } + if (*n < ((*n - 1) / usubc_1.nsmax + 1) * usubc_1.nsmin) { goto L120; } + if (usubc_1.irepl < 0 || usubc_1.irepl > 2) { goto L120; } + if (usubc_1.ifxsw < 1 || usubc_1.ifxsw > 3) { goto L120; } + if (usubc_1.bonus < 0.) { goto L120; } + if (usubc_1.nfstop < 0) { goto L120; } + } + + /* initialization */ + + istptr = *n + 1; + isptr = istptr + *n; + ifsptr = isptr + usubc_1.nsmax * (usubc_1.nsmax + 3); + insptr = *n + 1; + if (scale[1] > 0.) { + dcopy_(n, &scale[1], &c__1, &work[1], &c__1); + dcopy_(n, &scale[1], &c__1, &work[istptr], &c__1); + } + else { + dcopy_(n, &scl, &c__0, &work[1], &c__1); + dcopy_(n, &scl, &c__0, &work[istptr], &c__1); } - -/* subplex loop */ - -L40: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = (d__1 = work[i__], abs(d__1)); -/* L50: */ + iwork[i__] = i__; + /* L30: */ } - sortd_(n, &work[1], &iwork[1]); - partx_(n, &iwork[1], &work[1], &nsubs, &iwork[insptr]); - dcopy_(n, &x[1], &c__1, &work[1], &c__1); - ins = insptr; - insfnl = insptr + nsubs - 1; - ipptr = 1; - -/* simplex loop */ - -L60: - ns = iwork[ins]; -L70: - simplx_((D_fp)f, fdata, n, &work[istptr], &ns, &iwork[ipptr], maxnfe, &cmode, &x[ - 1], &sfx, nfe, &work[isptr], &work[ifsptr], iflag); + *nfe = 0; + usubc_1.nfxe = 1; + if (usubc_1.irepl == 0) { isubc_1.fbonus = 0.; } + else if (usubc_1.minf) { + isubc_1.fbonus = bnsfac[usubc_1.ifxsw - 1] * usubc_1.bonus; + } + else { + isubc_1.fbonus = bnsfac[usubc_1.ifxsw + 2] * usubc_1.bonus; + } + if (usubc_1.nfstop == 0) { isubc_1.sfstop = 0.; } + else if (usubc_1.minf) { + isubc_1.sfstop = usubc_1.fstop; + } + else { + isubc_1.sfstop = -usubc_1.fstop; + } + usubc_1.ftest = 0.; cmode = FALSE_; - if (*iflag != 0) { - goto L110; + isubc_1.new__ = TRUE_; + usubc_1.initx = TRUE_; + evalf_((D_fp)f, fdata, &c__0, &iwork[1], &dum, n, &x[1], &sfx, nfe); + usubc_1.initx = FALSE_; + } + else { + + /* continuation of previous call */ + + if (*iflag == 2) { + if (usubc_1.minf) { isubc_1.sfstop = usubc_1.fstop; } + else { + isubc_1.sfstop = -usubc_1.fstop; + } + cmode = TRUE_; + goto L70; + } + else if (*iflag == -1) { + cmode = TRUE_; + goto L70; + } + else if (*iflag == 0) { + cmode = FALSE_; + goto L90; } - if (ins < insfnl) { - ++ins; - ipptr += ns; - goto L60; + else { + return 0; } + } -/* end simplex loop */ + /* subplex loop */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = x[i__] - work[i__]; -/* L80: */ - } +L40: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = (d__1 = work[i__], abs(d__1)); + /* L50: */ + } + sortd_(n, &work[1], &iwork[1]); + partx_(n, &iwork[1], &work[1], &nsubs, &iwork[insptr]); + dcopy_(n, &x[1], &c__1, &work[1], &c__1); + ins = insptr; + insfnl = insptr + nsubs - 1; + ipptr = 1; + + /* simplex loop */ -/* check termination */ +L60: + ns = iwork[ins]; +L70: + simplx_((D_fp)f, fdata, n, &work[istptr], &ns, &iwork[ipptr], maxnfe, &cmode, &x[1], &sfx, nfe, + &work[isptr], &work[ifsptr], iflag); + cmode = FALSE_; + if (*iflag != 0) { goto L110; } + if (ins < insfnl) { + ++ins; + ipptr += ns; + goto L60; + } + + /* end simplex loop */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = x[i__] - work[i__]; + /* L80: */ + } + + /* check termination */ L90: - istep = istptr; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__4 = (d__2 = work[i__], abs(d__2)), d__5 = (d__1 = work[istep], abs( - d__1)) * usubc_1.psi; -/* Computing MAX */ - d__6 = (d__3 = x[i__], abs(d__3)); - if (max(d__4,d__5) / max(d__6,1.) > *tol) { - setstp_(&nsubs, n, &work[1], &work[istptr]); - goto L40; - } - ++istep; -/* L100: */ - } + istep = istptr; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + /* Computing MAX */ + d__4 = (d__2 = work[i__], abs(d__2)), d__5 = (d__1 = work[istep], abs(d__1)) * usubc_1.psi; + /* Computing MAX */ + d__6 = (d__3 = x[i__], abs(d__3)); + if (max(d__4, d__5) / max(d__6, 1.) > *tol) { + setstp_(&nsubs, n, &work[1], &work[istptr]); + goto L40; + } + ++istep; + /* L100: */ + } -/* end subplex loop */ + /* end subplex loop */ - *iflag = 0; + *iflag = 0; L110: - if (usubc_1.minf) { - *fx = sfx; - } else { - *fx = -sfx; - } - return 0; + if (usubc_1.minf) { *fx = sfx; } + else { + *fx = -sfx; + } + return 0; -/* invalid input */ + /* invalid input */ L120: - *iflag = -2; - return 0; + *iflag = -2; + return 0; } /* subplx_ */ /****************************************************************************/ @@ -2169,112 +1975,86 @@ Return value: value of f at minimum. */ -number subplex(multivar_func f, number *x, integer n, void *fdata, - number tol, integer maxnfe, - number fmin, boolean use_fmin, - number *scale, - integer *nfe, integer *errflag) -{ - integer mode = 0, *iwork, nsmax, nsmin; - number *work, fx; - - nsmax = min(5,n); - nsmin = min(2,n); - work = (number*) malloc(sizeof(number) * (2*n + nsmax*(nsmax+4) + 1)); - iwork = (integer*) malloc(sizeof(integer) * (n + n/nsmin + 1)); - if (!work || !iwork) { - fprintf(stderr, "subplex: error, out of memory!\n"); - exit(EXIT_FAILURE); - } - - if (use_fmin) { /* stop when fmin is reached */ - subopt_(&n); - usubc_1.nfstop = 1; - usubc_1.fstop = fmin; - mode = 2; - } - - subplx_(f,fdata, &n, - &tol, &maxnfe, &mode, - scale, x, - &fx, nfe, - work, iwork, errflag); +number subplex(multivar_func f, number *x, integer n, void *fdata, number tol, integer maxnfe, + number fmin, boolean use_fmin, number *scale, integer *nfe, integer *errflag) { + integer mode = 0, *iwork, nsmax, nsmin; + number *work, fx; + + nsmax = min(5, n); + nsmin = min(2, n); + work = (number *)malloc(sizeof(number) * (2 * n + nsmax * (nsmax + 4) + 1)); + iwork = (integer *)malloc(sizeof(integer) * (n + n / nsmin + 1)); + if (!work || !iwork) { + fprintf(stderr, "subplex: error, out of memory!\n"); + exit(EXIT_FAILURE); + } + + if (use_fmin) { /* stop when fmin is reached */ + subopt_(&n); + usubc_1.nfstop = 1; + usubc_1.fstop = fmin; + mode = 2; + } + + subplx_(f, fdata, &n, &tol, &maxnfe, &mode, scale, x, &fx, nfe, work, iwork, errflag); - free(iwork); - free(work); + free(iwork); + free(work); - return fx; + return fx; } -number f_scm_wrapper(integer n, number *x, void *f_scm_p) -{ - SCM *f_scm = (SCM *) f_scm_p; - return ctl_convert_number_to_c(gh_call1(*f_scm, make_number_list(n, x))); +number f_scm_wrapper(integer n, number *x, void *f_scm_p) { + SCM *f_scm = (SCM *)f_scm_p; + return ctl_convert_number_to_c(gh_call1(*f_scm, make_number_list(n, x))); } /* Scheme-callable wrapper for subplex() function, above. */ -SCM subplex_scm(SCM f_scm, SCM x_scm, - SCM tol_scm, SCM maxnfe_scm, - SCM fmin_scm, SCM use_fmin_scm, - SCM scale_scm) -{ - number *x, tol, *scale, fx, fmin; - integer i, n, maxnfe, nfe, errflag, scale_len; - boolean use_fmin; - SCM retval; - - n = list_length(x_scm); - tol = fabs(ctl_convert_number_to_c(tol_scm)); - maxnfe = ctl_convert_integer_to_c(maxnfe_scm); - fmin = ctl_convert_number_to_c(fmin_scm); - use_fmin = ctl_convert_boolean_to_c(use_fmin_scm); - - scale_len = list_length(scale_scm); - if (scale_len != 1 && scale_len != n) { - fprintf(stderr, "subplex: invalid scale argument length %d\n", - scale_len); - return SCM_UNDEFINED; - } - - x = (number*) malloc(sizeof(number) * n); - scale = (number*) malloc(sizeof(number) * scale_len); - if (!x || !scale) { - fprintf(stderr, "subplex: error, out of memory!\n"); - exit(EXIT_FAILURE); - } - - for (i = 0; i < n; ++i) - x[i] = number_list_ref(x_scm, i); - for (i = 0; i < scale_len; ++i) - scale[i] = fabs(number_list_ref(scale_scm, i)); - if (scale_len == 1 && scale_len != n) - *scale *= -1; - - fx = subplex(f_scm_wrapper, x, n, &f_scm, - tol, maxnfe, - fmin, use_fmin, - scale, - &nfe, &errflag); - - switch (errflag) { - case -2: - fprintf(stderr, "subplex error: invalid inputs\n"); - return SCM_UNDEFINED; - case -1: - fprintf(stderr, "subplex warning: max # iterations exceeded\n"); - break; - case 1: - fprintf(stderr, "subplex warning: machine precision reached\n"); - break; - case 2: - fprintf(stderr, "subplex warning: fstop reached\n"); - break; - } +SCM subplex_scm(SCM f_scm, SCM x_scm, SCM tol_scm, SCM maxnfe_scm, SCM fmin_scm, SCM use_fmin_scm, + SCM scale_scm) { + number *x, tol, *scale, fx, fmin; + integer i, n, maxnfe, nfe, errflag, scale_len; + boolean use_fmin; + SCM retval; + + n = list_length(x_scm); + tol = fabs(ctl_convert_number_to_c(tol_scm)); + maxnfe = ctl_convert_integer_to_c(maxnfe_scm); + fmin = ctl_convert_number_to_c(fmin_scm); + use_fmin = ctl_convert_boolean_to_c(use_fmin_scm); + + scale_len = list_length(scale_scm); + if (scale_len != 1 && scale_len != n) { + fprintf(stderr, "subplex: invalid scale argument length %d\n", scale_len); + return SCM_UNDEFINED; + } + + x = (number *)malloc(sizeof(number) * n); + scale = (number *)malloc(sizeof(number) * scale_len); + if (!x || !scale) { + fprintf(stderr, "subplex: error, out of memory!\n"); + exit(EXIT_FAILURE); + } + + for (i = 0; i < n; ++i) + x[i] = number_list_ref(x_scm, i); + for (i = 0; i < scale_len; ++i) + scale[i] = fabs(number_list_ref(scale_scm, i)); + if (scale_len == 1 && scale_len != n) *scale *= -1; + + fx = subplex(f_scm_wrapper, x, n, &f_scm, tol, maxnfe, fmin, use_fmin, scale, &nfe, &errflag); + + switch (errflag) { + case -2: fprintf(stderr, "subplex error: invalid inputs\n"); return SCM_UNDEFINED; + case -1: fprintf(stderr, "subplex warning: max # iterations exceeded\n"); break; + case 1: fprintf(stderr, "subplex warning: machine precision reached\n"); break; + case 2: fprintf(stderr, "subplex warning: fstop reached\n"); break; + } - retval = gh_cons(make_number_list(n, x), ctl_convert_number_to_scm(fx)); + retval = gh_cons(make_number_list(n, x), ctl_convert_number_to_scm(fx)); - free(scale); - free(x); + free(scale); + free(x); - return retval; + return retval; } diff -Nru libctl-4.4.0/utils/ctlgeom.h libctl-4.5.0/utils/ctlgeom.h --- libctl-4.4.0/utils/ctlgeom.h 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/ctlgeom.h 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -23,38 +23,38 @@ #define GEOM_H #ifdef CXX_CTL_IO -# define MATERIAL_TYPE ctlio::material_type -# define GEOMETRIC_OBJECT ctlio::geometric_object -# define GEOMETRIC_OBJECT_LIST ctlio::geometric_object_list -# define LATTICE ctlio::lattice +#define MATERIAL_TYPE ctlio::material_type +#define GEOMETRIC_OBJECT ctlio::geometric_object +#define GEOMETRIC_OBJECT_LIST ctlio::geometric_object_list +#define LATTICE ctlio::lattice #else -# define MATERIAL_TYPE material_type -# define GEOMETRIC_OBJECT geometric_object -# define GEOMETRIC_OBJECT_LIST geometric_object_list -# define LATTICE lattice +#define MATERIAL_TYPE material_type +#define GEOMETRIC_OBJECT geometric_object +#define GEOMETRIC_OBJECT_LIST geometric_object_list +#define LATTICE lattice #endif #ifndef CTL_IO_H /* for libctlgeom */ -# undef MATERIAL_TYPE -# define MATERIAL_TYPE void* +#undef MATERIAL_TYPE +#define MATERIAL_TYPE void * #endif /* Where possible (e.g. for gcc >= 3.1), enable a compiler warning for code that uses a deprecated function */ -#if defined(__GNUC__) && (__GNUC__ > 3 || (__GNUC__==3 && __GNUC_MINOR__ > 0)) -# define CTLGEOM_DEPRECATED __attribute__((deprecated)) +#if defined(__GNUC__) && (__GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ > 0)) +#define CTLGEOM_DEPRECATED __attribute__((deprecated)) #else -# define CTLGEOM_DEPRECATED +#define CTLGEOM_DEPRECATED #endif #ifdef __cplusplus extern "C" { -#endif /* __cplusplus */ +#endif /* __cplusplus */ /**************************************************************************/ #ifndef CTL_IO_H -# include +#include extern void display_geometric_object_info(int indentby, geometric_object o); #endif @@ -78,19 +78,15 @@ extern vector3 from_geom_object_coords(vector3 p, GEOMETRIC_OBJECT o); extern vector3 normal_to_object(vector3 p, GEOMETRIC_OBJECT o); extern vector3 normal_to_fixed_object(vector3 p, GEOMETRIC_OBJECT o); -extern int intersect_line_with_object(vector3 p, vector3 d, GEOMETRIC_OBJECT o, - double s[2]); -extern double intersect_line_segment_with_object(vector3 p, vector3 d, - GEOMETRIC_OBJECT o, - double a, double b); +extern int intersect_line_with_object(vector3 p, vector3 d, GEOMETRIC_OBJECT o, double s[2]); +extern double intersect_line_segment_with_object(vector3 p, vector3 d, GEOMETRIC_OBJECT o, double a, + double b); extern MATERIAL_TYPE material_of_point_inobject(vector3 p, boolean *inobject); -extern MATERIAL_TYPE material_of_point_inobject0( - GEOMETRIC_OBJECT_LIST geometry, vector3 p, boolean *inobject); +extern MATERIAL_TYPE material_of_point_inobject0(GEOMETRIC_OBJECT_LIST geometry, vector3 p, + boolean *inobject); extern MATERIAL_TYPE material_of_point(vector3 p); -extern MATERIAL_TYPE material_of_point0(GEOMETRIC_OBJECT_LIST geometry, - vector3 p); -GEOMETRIC_OBJECT object_of_point0(GEOMETRIC_OBJECT_LIST geometry, vector3 p, - vector3 *shiftby); +extern MATERIAL_TYPE material_of_point0(GEOMETRIC_OBJECT_LIST geometry, vector3 p); +GEOMETRIC_OBJECT object_of_point0(GEOMETRIC_OBJECT_LIST geometry, vector3 p, vector3 *shiftby); GEOMETRIC_OBJECT object_of_point(vector3 p, vector3 *shiftby); vector3 shift_to_unit_cell(vector3 p); extern matrix3x3 square_basis(matrix3x3 lattice_basis, vector3 size); @@ -98,86 +94,91 @@ extern void (*ctl_printf_callback)(const char *s); typedef struct { - vector3 low, high; + vector3 low, high; } geom_box; typedef struct { - geom_box box; - const GEOMETRIC_OBJECT *o; - vector3 shiftby; - int precedence; + geom_box box; + const GEOMETRIC_OBJECT *o; + vector3 shiftby; + int precedence; } geom_box_object; typedef struct geom_box_tree_struct { - geom_box b, b1, b2; - struct geom_box_tree_struct *t1, *t2; - int nobjects; - geom_box_object *objects; -} *geom_box_tree; + geom_box b, b1, b2; + struct geom_box_tree_struct *t1, *t2; + int nobjects; + geom_box_object *objects; +} * geom_box_tree; extern void destroy_geom_box_tree(geom_box_tree t); extern geom_box_tree create_geom_box_tree(void); -extern geom_box_tree create_geom_box_tree0(GEOMETRIC_OBJECT_LIST geometry, - geom_box b0); +extern geom_box_tree create_geom_box_tree0(GEOMETRIC_OBJECT_LIST geometry, geom_box b0); extern geom_box_tree restrict_geom_box_tree(geom_box_tree, const geom_box *); extern geom_box_tree geom_tree_search(vector3 p, geom_box_tree t, int *oindex); extern geom_box_tree geom_tree_search_next(vector3 p, geom_box_tree t, int *oindex); -extern MATERIAL_TYPE material_of_point_in_tree_inobject(vector3 p, geom_box_tree t, boolean *inobject); +extern MATERIAL_TYPE material_of_point_in_tree_inobject(vector3 p, geom_box_tree t, + boolean *inobject); extern MATERIAL_TYPE material_of_point_in_tree(vector3 p, geom_box_tree t); -extern MATERIAL_TYPE material_of_unshifted_point_in_tree_inobject(vector3 p, geom_box_tree t, boolean *inobject); -const GEOMETRIC_OBJECT *object_of_point_in_tree(vector3 p, geom_box_tree t, - vector3 *shiftby, - int *precedence); +extern MATERIAL_TYPE material_of_unshifted_point_in_tree_inobject(vector3 p, geom_box_tree t, + boolean *inobject); +const GEOMETRIC_OBJECT *object_of_point_in_tree(vector3 p, geom_box_tree t, vector3 *shiftby, + int *precedence); extern vector3 to_geom_box_coords(vector3 p, geom_box_object *gbo); extern void display_geom_box_tree(int indentby, geom_box_tree t); extern void geom_box_tree_stats(geom_box_tree t, int *depth, int *nobjects); extern void geom_get_bounding_box(GEOMETRIC_OBJECT o, geom_box *box); extern number box_overlap_with_object(geom_box b, GEOMETRIC_OBJECT o, number tol, integer maxeval); -extern number ellipsoid_overlap_with_object(geom_box b, GEOMETRIC_OBJECT o, number tol, integer maxeval); -extern number range_overlap_with_object(vector3 low, vector3 high, - GEOMETRIC_OBJECT o, number tol, - integer maxeval); +extern number ellipsoid_overlap_with_object(geom_box b, GEOMETRIC_OBJECT o, number tol, + integer maxeval); +extern number range_overlap_with_object(vector3 low, vector3 high, GEOMETRIC_OBJECT o, number tol, + integer maxeval); extern vector3 get_grid_size(void); extern vector3 get_resolution(void); extern void get_grid_size_n(int *nx, int *ny, int *nz); GEOMETRIC_OBJECT make_geometric_object(MATERIAL_TYPE material, vector3 center); -GEOMETRIC_OBJECT make_cylinder(MATERIAL_TYPE material, vector3 center, - number radius, number height, vector3 axis); -GEOMETRIC_OBJECT make_wedge(MATERIAL_TYPE material, vector3 center, - number radius, number height, vector3 axis, - number wedge_angle, vector3 wedge_start); -GEOMETRIC_OBJECT make_cone(MATERIAL_TYPE material, vector3 center, - number radius, number height, vector3 axis, - number radius2); -GEOMETRIC_OBJECT make_sphere(MATERIAL_TYPE material, vector3 center, - number radius); -GEOMETRIC_OBJECT make_block(MATERIAL_TYPE material, vector3 center, - vector3 e1, vector3 e2, vector3 e3, - vector3 size); -GEOMETRIC_OBJECT make_ellipsoid(MATERIAL_TYPE material, vector3 center, - vector3 e1, vector3 e2, vector3 e3, - vector3 size); +GEOMETRIC_OBJECT make_cylinder(MATERIAL_TYPE material, vector3 center, number radius, number height, + vector3 axis); +GEOMETRIC_OBJECT make_wedge(MATERIAL_TYPE material, vector3 center, number radius, number height, + vector3 axis, number wedge_angle, vector3 wedge_start); +GEOMETRIC_OBJECT make_cone(MATERIAL_TYPE material, vector3 center, number radius, number height, + vector3 axis, number radius2); +GEOMETRIC_OBJECT make_sphere(MATERIAL_TYPE material, vector3 center, number radius); +GEOMETRIC_OBJECT make_block(MATERIAL_TYPE material, vector3 center, vector3 e1, vector3 e2, + vector3 e3, vector3 size); +GEOMETRIC_OBJECT make_ellipsoid(MATERIAL_TYPE material, vector3 center, vector3 e1, vector3 e2, + vector3 e3, vector3 size); + +extern boolean node_in_or_on_polygon(vector3 q0, vector3 *nodes, int num_nodes, + boolean include_boundaries); // prism with `center` field computed automatically from vertices, height, axis -GEOMETRIC_OBJECT make_prism(MATERIAL_TYPE material, - const vector3 *vertices, int num_vertices, - double height, vector3 axis); +GEOMETRIC_OBJECT make_prism(MATERIAL_TYPE material, const vector3 *vertices, int num_vertices, + double height, vector3 axis); // as make_prism, but with a rigid translation so that the prism is centered at center GEOMETRIC_OBJECT make_prism_with_center(MATERIAL_TYPE material, vector3 center, - const vector3 *vertices, int num_vertices, - double height, vector3 axis); + const vector3 *vertices, int num_vertices, double height, + vector3 axis); +// slanted prism with `center` field computed automatically from vertices, height, axis, sidewall_angle +GEOMETRIC_OBJECT make_slanted_prism(MATERIAL_TYPE material, const vector3 *vertices, int num_vertices, + double height, vector3 axis, double sidewall_angle); + +// as make_slanted_prism, but with a rigid translation so that the prism is centered at center +GEOMETRIC_OBJECT make_slanted_prism_with_center(MATERIAL_TYPE material, vector3 center, + const vector3 *vertices, int num_vertices, double height, + vector3 axis, double sidewall_angle); int vector3_nearly_equal(vector3 v1, vector3 v2, double tolerance); /**************************************************************************/ #ifdef __cplusplus -} /* extern "C" */ -#endif /* __cplusplus */ +} /* extern "C" */ +#endif /* __cplusplus */ #endif /* GEOM_H */ diff -Nru libctl-4.4.0/utils/ctl-io.scm libctl-4.5.0/utils/ctl-io.scm --- libctl-4.4.0/utils/ctl-io.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/ctl-io.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/utils/gen-ctl-io.1 libctl-4.5.0/utils/gen-ctl-io.1 --- libctl-4.4.0/utils/gen-ctl-io.1 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/gen-ctl-io.1 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ .\" libctl: flexible Guile-based control files for scientific software -.\" Copyright (C) 1998-2019 Steven G. Johnson +.\" Copyright (C) 1998-2020 Steven G. Johnson .\" .\" This library is free software; you can redistribute it and/or .\" modify it under the terms of the GNU Lesser General Public diff -Nru libctl-4.4.0/utils/geom.c libctl-4.5.0/utils/geom.c --- libctl-4.4.0/utils/geom.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/geom.c 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -27,51 +27,57 @@ #include #ifndef LIBCTLGEOM -# include "ctl-io.h" +#include "ctl-io.h" #else -# define material_type void* - static void material_type_copy(void **src, void **dest) { *dest = *src; } +#define material_type void * +static void material_type_copy(void **src, void **dest) { *dest = *src; } #endif #include "ctlgeom.h" #ifdef CXX_CTL_IO using namespace ctlio; -# define CTLIO ctlio:: -# define GEOM geometric_object:: -# define BLK block:: -# define CYL cylinder:: -# define MAT material_type:: +#define CTLIO ctlio:: +#define GEOM geometric_object:: +#define BLK block:: +#define CYL cylinder:: +#define MAT material_type:: #else -# define CTLIO -# define GEOM -# define BLK -# define CYL -# define MAT +#define CTLIO +#define GEOM +#define BLK +#define CYL +#define MAT #endif #ifdef __cplusplus -# define MALLOC(type,num) (new type[num]) -# define MALLOC1(type) (new type) -# define FREE(p) delete[] (p) -# define FREE1(p) delete (p) +#define MALLOC(type, num) (new type[num]) +#define MALLOC1(type) (new type) +#define FREE(p) delete[](p) +#define FREE1(p) delete (p) #else -# define MALLOC(type,num) ((type *) malloc(sizeof(type) * (num))) -# define MALLOC1(type) MALLOC(type,1) -# define FREE(p) free(p) -# define FREE1(p) free(p) +#define MALLOC(type, num) ((type *)malloc(sizeof(type) * (num))) +#define MALLOC1(type) MALLOC(type, 1) +#define FREE(p) free(p) +#define FREE1(p) free(p) #endif #define K_PI 3.14159265358979323846 -#define CHECK(cond, s) if (!(cond)){fprintf(stderr,s "\n");exit(EXIT_FAILURE);} +#define CHECK(cond, s) \ + if (!(cond)) { \ + fprintf(stderr, s "\n"); \ + exit(EXIT_FAILURE); \ + } -#define MAX(a,b) ((a) > (b) ? (a) : (b)) -#define MIN(a,b) ((a) < (b) ? (a) : (b)) +#define MAX(a, b) ((a) > (b) ? (a) : (b)) +#define MIN(a, b) ((a) < (b) ? (a) : (b)) // forward declarations of prism-related routines, at the bottom of this file static boolean node_in_polygon(double qx, double qy, vector3 *nodes, int num_nodes); static boolean point_in_prism(prism *prsm, vector3 pc); static vector3 normal_to_prism(prism *prsm, vector3 pc); -static double intersect_line_segment_with_prism(prism *prsm, vector3 pc, vector3 dc, double a, double b); +static double intersect_line_segment_with_prism(prism *prsm, vector3 pc, vector3 dc, double a, + double b); +static double get_prism_volume(prism *prsm); static void get_prism_bounding_box(prism *prsm, geom_box *box); static void display_prism_info(int indentby, geometric_object *o); static void init_prism(geometric_object *o); @@ -80,8 +86,7 @@ /* Allows writing to Python's stdout when running from Meep's Python interface */ void (*ctl_printf_callback)(const char *s) = NULL; -void ctl_printf(const char *fmt, ...) -{ +void ctl_printf(const char *fmt, ...) { va_list ap; va_start(ap, fmt); if (ctl_printf_callback) { @@ -89,7 +94,8 @@ CHECK(vasprintf(&s, fmt, ap) >= 0, "vasprintf failed"); ctl_printf_callback(s); free(s); - } else { + } + else { vprintf(fmt, ap); fflush(stdout); } @@ -98,25 +104,17 @@ /* If v is a vector in the lattice basis, normalize v so that its cartesian length is unity. */ -static void lattice_normalize(vector3 *v) -{ - *v = vector3_scale( - 1.0 / - sqrt(vector3_dot(*v, - matrix3x3_vector3_mult(geometry_lattice.metric, - *v))), - *v); -} - -static vector3 lattice_to_cartesian(vector3 v) -{ - return matrix3x3_vector3_mult(geometry_lattice.basis, v); -} - -static vector3 cartesian_to_lattice(vector3 v) -{ - return matrix3x3_vector3_mult(matrix3x3_inverse(geometry_lattice.basis), - v); +static void lattice_normalize(vector3 *v) { + *v = vector3_scale( + 1.0 / sqrt(vector3_dot(*v, matrix3x3_vector3_mult(geometry_lattice.metric, *v))), *v); +} + +static vector3 lattice_to_cartesian(vector3 v) { + return matrix3x3_vector3_mult(geometry_lattice.basis, v); +} + +static vector3 cartesian_to_lattice(vector3 v) { + return matrix3x3_vector3_mult(matrix3x3_inverse(geometry_lattice.basis), v); } /* geom_fix_object_ptr is called after an object's externally-configurable parameters @@ -132,130 +130,111 @@ Unfortunately, we can't do this stuff at object-creation time in Guile, because the geometry_lattice variable may not have been assigned to its final value at that point. */ -void geom_fix_object_ptr(geometric_object *o) -{ - switch(o->which_subclass) { - case GEOM CYLINDER: - lattice_normalize(&o->subclass.cylinder_data->axis); - if (o->subclass.cylinder_data->which_subclass == CYL WEDGE) { - vector3 a = o->subclass.cylinder_data->axis; - vector3 s = o->subclass.cylinder_data->subclass.wedge_data->wedge_start; - double p = vector3_dot(s, matrix3x3_vector3_mult(geometry_lattice.metric, a)); - o->subclass.cylinder_data->subclass.wedge_data->e1 = - vector3_minus(s, vector3_scale(p, a)); - lattice_normalize(&o->subclass.cylinder_data->subclass.wedge_data->e1); - o->subclass.cylinder_data->subclass.wedge_data->e2 = - cartesian_to_lattice( - vector3_cross(lattice_to_cartesian(o->subclass.cylinder_data->axis), - lattice_to_cartesian(o->subclass.cylinder_data->subclass.wedge_data->e1))); - } - break; - case GEOM BLOCK: - { - matrix3x3 m; - lattice_normalize(&o->subclass.block_data->e1); - lattice_normalize(&o->subclass.block_data->e2); - lattice_normalize(&o->subclass.block_data->e3); - m.c0 = o->subclass.block_data->e1; - m.c1 = o->subclass.block_data->e2; - m.c2 = o->subclass.block_data->e3; - o->subclass.block_data->projection_matrix = matrix3x3_inverse(m); - break; - } - case GEOM PRISM: - { - init_prism(o); - break; - } - case GEOM COMPOUND_GEOMETRIC_OBJECT: - { - int i; - int n = o->subclass.compound_geometric_object_data->component_objects.num_items; - geometric_object *os = o->subclass.compound_geometric_object_data->component_objects.items; - for (i = 0; i < n; ++i) { +void geom_fix_object_ptr(geometric_object *o) { + switch (o->which_subclass) { + case GEOM CYLINDER: + lattice_normalize(&o->subclass.cylinder_data->axis); + if (o->subclass.cylinder_data->which_subclass == CYL WEDGE) { + vector3 a = o->subclass.cylinder_data->axis; + vector3 s = o->subclass.cylinder_data->subclass.wedge_data->wedge_start; + double p = vector3_dot(s, matrix3x3_vector3_mult(geometry_lattice.metric, a)); + o->subclass.cylinder_data->subclass.wedge_data->e1 = vector3_minus(s, vector3_scale(p, a)); + lattice_normalize(&o->subclass.cylinder_data->subclass.wedge_data->e1); + o->subclass.cylinder_data->subclass.wedge_data->e2 = cartesian_to_lattice(vector3_cross( + lattice_to_cartesian(o->subclass.cylinder_data->axis), + lattice_to_cartesian(o->subclass.cylinder_data->subclass.wedge_data->e1))); + } + break; + case GEOM BLOCK: { + matrix3x3 m; + lattice_normalize(&o->subclass.block_data->e1); + lattice_normalize(&o->subclass.block_data->e2); + lattice_normalize(&o->subclass.block_data->e3); + m.c0 = o->subclass.block_data->e1; + m.c1 = o->subclass.block_data->e2; + m.c2 = o->subclass.block_data->e3; + o->subclass.block_data->projection_matrix = matrix3x3_inverse(m); + break; + } + case GEOM PRISM: { + init_prism(o); + break; + } + case GEOM COMPOUND_GEOMETRIC_OBJECT: { + int i; + int n = o->subclass.compound_geometric_object_data->component_objects.num_items; + geometric_object *os = o->subclass.compound_geometric_object_data->component_objects.items; + for (i = 0; i < n; ++i) { #if MATERIAL_TYPE_ABSTRACT - if (os[i].material.which_subclass == MAT MATERIAL_TYPE_SELF) - material_type_copy(&o->material, &os[i].material); + if (os[i].material.which_subclass == MAT MATERIAL_TYPE_SELF) + material_type_copy(&o->material, &os[i].material); #endif - geom_fix_object_ptr(os + i); - } - break; - } - case GEOM GEOMETRIC_OBJECT_SELF: case GEOM SPHERE: - break; /* these objects are fine */ - } + geom_fix_object_ptr(os + i); + } + break; + } + case GEOM GEOMETRIC_OBJECT_SELF: + case GEOM SPHERE: break; /* these objects are fine */ + } } // deprecated API — doesn't work for prisms -void geom_fix_object(geometric_object o) -{ - geom_fix_object_ptr(&o); -} +void geom_fix_object(geometric_object o) { geom_fix_object_ptr(&o); } /* fix all objects in the geometry list as described in geom_fix_object, above */ -void geom_fix_object_list(geometric_object_list geometry) -{ - int index; - - for (index = 0; index < geometry.num_items; ++index) - geom_fix_object_ptr(geometry.items + index); -} - -void geom_fix_objects0(geometric_object_list geometry) -{ - geom_fix_object_list(geometry); -} - -void geom_fix_objects(void) -{ - geom_fix_object_list(geometry); -} - -void geom_fix_lattice0(lattice *L) -{ - L->basis1 = unit_vector3(L->basis1); - L->basis2 = unit_vector3(L->basis2); - L->basis3 = unit_vector3(L->basis3); - L->b1 = vector3_scale(L->basis_size.x, L->basis1); - L->b2 = vector3_scale(L->basis_size.y, L->basis2); - L->b3 = vector3_scale(L->basis_size.z, L->basis3); - L->basis.c0 = L->b1; - L->basis.c1 = L->b2; - L->basis.c2 = L->b3; - L->metric = matrix3x3_mult(matrix3x3_transpose(L->basis), L->basis); -} - -void geom_fix_lattice(void) -{ - geom_fix_lattice0(&geometry_lattice); -} - -void geom_cartesian_lattice0(lattice *L) -{ - L->basis1.x = 1; L->basis1.y = 0; L->basis1.z = 0; - L->basis2.x = 0; L->basis2.y = 1; L->basis2.z = 0; - L->basis3.x = 0; L->basis3.y = 0; L->basis3.z = 1; - L->basis_size.x = L->basis_size.y = L->basis_size.z = 1; - geom_fix_lattice0(L); -} - -void geom_cartesian_lattice(void) -{ - geom_cartesian_lattice0(&geometry_lattice); -} - -void geom_initialize(void) -{ - /* initialize many of the input variables that are normally - initialized from Scheme, except for default_material and - geometry_lattice.size. */ - geom_cartesian_lattice(); - geometry_center.x = geometry_center.y = geometry_center.z = 0; - dimensions = 3; - ensure_periodicity = 1; - geometry.num_items = 0; - geometry.items = 0; +void geom_fix_object_list(geometric_object_list geometry) { + int index; + + for (index = 0; index < geometry.num_items; ++index) + geom_fix_object_ptr(geometry.items + index); +} + +void geom_fix_objects0(geometric_object_list geometry) { geom_fix_object_list(geometry); } + +void geom_fix_objects(void) { geom_fix_object_list(geometry); } + +void geom_fix_lattice0(lattice *L) { + L->basis1 = unit_vector3(L->basis1); + L->basis2 = unit_vector3(L->basis2); + L->basis3 = unit_vector3(L->basis3); + L->b1 = vector3_scale(L->basis_size.x, L->basis1); + L->b2 = vector3_scale(L->basis_size.y, L->basis2); + L->b3 = vector3_scale(L->basis_size.z, L->basis3); + L->basis.c0 = L->b1; + L->basis.c1 = L->b2; + L->basis.c2 = L->b3; + L->metric = matrix3x3_mult(matrix3x3_transpose(L->basis), L->basis); +} + +void geom_fix_lattice(void) { geom_fix_lattice0(&geometry_lattice); } + +void geom_cartesian_lattice0(lattice *L) { + L->basis1.x = 1; + L->basis1.y = 0; + L->basis1.z = 0; + L->basis2.x = 0; + L->basis2.y = 1; + L->basis2.z = 0; + L->basis3.x = 0; + L->basis3.y = 0; + L->basis3.z = 1; + L->basis_size.x = L->basis_size.y = L->basis_size.z = 1; + geom_fix_lattice0(L); +} + +void geom_cartesian_lattice(void) { geom_cartesian_lattice0(&geometry_lattice); } + +void geom_initialize(void) { + /* initialize many of the input variables that are normally + initialized from Scheme, except for default_material and + geometry_lattice.size. */ + geom_cartesian_lattice(); + geometry_center.x = geometry_center.y = geometry_center.z = 0; + dimensions = 3; + ensure_periodicity = 1; + geometry.num_items = 0; + geometry.items = 0; } /**************************************************************************/ @@ -269,107 +248,85 @@ point_in_fixed_objectp additionally requires that geom_fix_object has been called on o (if the lattice basis is non-orthogonal). */ -boolean CTLIO point_in_objectp(vector3 p, geometric_object o) -{ - geom_fix_object_ptr(&o); - return point_in_fixed_objectp(p, o); +boolean CTLIO point_in_objectp(vector3 p, geometric_object o) { + geom_fix_object_ptr(&o); + return point_in_fixed_objectp(p, o); } -boolean point_in_fixed_objectp(vector3 p, geometric_object o) -{ - return point_in_fixed_pobjectp(p, &o); +boolean point_in_fixed_objectp(vector3 p, geometric_object o) { + return point_in_fixed_pobjectp(p, &o); } /* as point_in_fixed_objectp, but sets o to the object in question (if true) (which may be different from the input o if o is a compound object) */ -boolean point_in_fixed_pobjectp(vector3 p, geometric_object *o) -{ - vector3 r = vector3_minus(p,o->center); +boolean point_in_fixed_pobjectp(vector3 p, geometric_object *o) { + vector3 r = vector3_minus(p, o->center); switch (o->which_subclass) { - case GEOM GEOMETRIC_OBJECT_SELF: - return 0; - case GEOM SPHERE: - { + case GEOM GEOMETRIC_OBJECT_SELF: return 0; + case GEOM SPHERE: { number radius = o->subclass.sphere_data->radius; - return(radius > 0.0 && - vector3_dot(r,matrix3x3_vector3_mult(geometry_lattice.metric, r)) - <= radius*radius); + return (radius > 0.0 && vector3_dot(r, matrix3x3_vector3_mult(geometry_lattice.metric, r)) <= + radius * radius); } - case GEOM CYLINDER: - { + case GEOM CYLINDER: { vector3 rm = matrix3x3_vector3_mult(geometry_lattice.metric, r); number proj = vector3_dot(o->subclass.cylinder_data->axis, rm); number height = o->subclass.cylinder_data->height; if (fabs(proj) <= 0.5 * height) { - number radius = o->subclass.cylinder_data->radius; - if (o->subclass.cylinder_data->which_subclass == CYL CONE) - radius += (proj/height + 0.5) * - (o->subclass.cylinder_data->subclass.cone_data->radius2 - - radius); - else if (o->subclass.cylinder_data->which_subclass == CYL WEDGE) { - number x = vector3_dot(rm, o->subclass.cylinder_data->subclass.wedge_data->e1); - number y = vector3_dot(rm, o->subclass.cylinder_data->subclass.wedge_data->e2); - number theta = atan2(y, x); - number wedge_angle = o->subclass.cylinder_data->subclass.wedge_data->wedge_angle; - if (wedge_angle > 0) { - if (theta < 0) theta = theta + 2 * K_PI; - if (theta > wedge_angle) return 0; - } - else { - if (theta > 0) theta = theta - 2 * K_PI; - if (theta < wedge_angle) return 0; - } - } - return(radius != 0.0 && vector3_dot(r,rm) - proj*proj <= radius*radius); + number radius = o->subclass.cylinder_data->radius; + if (o->subclass.cylinder_data->which_subclass == CYL CONE) + radius += (proj / height + 0.5) * + (o->subclass.cylinder_data->subclass.cone_data->radius2 - radius); + else if (o->subclass.cylinder_data->which_subclass == CYL WEDGE) { + number x = vector3_dot(rm, o->subclass.cylinder_data->subclass.wedge_data->e1); + number y = vector3_dot(rm, o->subclass.cylinder_data->subclass.wedge_data->e2); + number theta = atan2(y, x); + number wedge_angle = o->subclass.cylinder_data->subclass.wedge_data->wedge_angle; + if (wedge_angle > 0) { + if (theta < 0) theta = theta + 2 * K_PI; + if (theta > wedge_angle) return 0; + } + else { + if (theta > 0) theta = theta - 2 * K_PI; + if (theta < wedge_angle) return 0; + } + } + return (radius != 0.0 && vector3_dot(r, rm) - proj * proj <= radius * radius); } else - return 0; + return 0; } - case GEOM BLOCK: - { - vector3 proj = - matrix3x3_vector3_mult(o->subclass.block_data->projection_matrix, r); + case GEOM BLOCK: { + vector3 proj = matrix3x3_vector3_mult(o->subclass.block_data->projection_matrix, r); switch (o->subclass.block_data->which_subclass) { - case BLK BLOCK_SELF: - { - vector3 size = o->subclass.block_data->size; - return(fabs(proj.x) <= 0.5 * size.x && - fabs(proj.y) <= 0.5 * size.y && - fabs(proj.z) <= 0.5 * size.z); - } - case BLK ELLIPSOID: - { - vector3 isa = - o->subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes; - double - a = proj.x * isa.x, - b = proj.y * isa.y, - c = proj.z * isa.z; - return(a*a + b*b + c*c <= 1.0); - } + case BLK BLOCK_SELF: { + vector3 size = o->subclass.block_data->size; + return (fabs(proj.x) <= 0.5 * size.x && fabs(proj.y) <= 0.5 * size.y && + fabs(proj.z) <= 0.5 * size.z); + } + case BLK ELLIPSOID: { + vector3 isa = o->subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes; + double a = proj.x * isa.x, b = proj.y * isa.y, c = proj.z * isa.z; + return (a * a + b * b + c * c <= 1.0); + } } - break; // never get here but silence compiler warning + break; // never get here but silence compiler warning } - case GEOM PRISM: - { + case GEOM PRISM: { return point_in_prism(o->subclass.prism_data, p); } - case GEOM COMPOUND_GEOMETRIC_OBJECT: - { - int i; - int n = o->subclass.compound_geometric_object_data - ->component_objects.num_items; - geometric_object *os = o->subclass.compound_geometric_object_data - ->component_objects.items; - vector3 shiftby = o->center; - for (i = 0; i < n; ++i) { - *o = os[i]; - o->center = vector3_plus(o->center, shiftby); - if (point_in_fixed_pobjectp(p, o)) - return 1; - } - break; + case GEOM COMPOUND_GEOMETRIC_OBJECT: { + int i; + int n = o->subclass.compound_geometric_object_data->component_objects.num_items; + geometric_object *os = o->subclass.compound_geometric_object_data->component_objects.items; + vector3 shiftby = o->center; + for (i = 0; i < n; ++i) { + *o = os[i]; + o->center = vector3_plus(o->center, shiftby); + if (point_in_fixed_pobjectp(p, o)) return 1; + } + break; } } return 0; @@ -379,67 +336,56 @@ /* convert a point p inside o to a coordinate in [0,1]^3 that is some "natural" coordinate for the object */ -vector3 to_geom_object_coords(vector3 p, geometric_object o) -{ +vector3 to_geom_object_coords(vector3 p, geometric_object o) { const vector3 half = {0.5, 0.5, 0.5}; - vector3 r = vector3_minus(p,o.center); + vector3 r = vector3_minus(p, o.center); switch (o.which_subclass) { - default: { - vector3 po = {0,0,0}; - return po; - } - case GEOM SPHERE: - { + default: { + vector3 po = {0, 0, 0}; + return po; + } + case GEOM SPHERE: { number radius = o.subclass.sphere_data->radius; return vector3_plus(half, vector3_scale(0.5 / radius, r)); } - /* case GEOM CYLINDER: - NOT YET IMPLEMENTED */ - case GEOM BLOCK: - { - vector3 proj = - matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, r); + /* case GEOM CYLINDER: + NOT YET IMPLEMENTED */ + case GEOM BLOCK: { + vector3 proj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, r); vector3 size = o.subclass.block_data->size; if (size.x != 0.0) proj.x /= size.x; if (size.y != 0.0) proj.y /= size.y; if (size.z != 0.0) proj.z /= size.z; return vector3_plus(half, proj); } -/* case GEOM PRISM: - NOT YET IMPLEMENTED */ + /* case GEOM PRISM: + NOT YET IMPLEMENTED */ } } /* inverse of to_geom_object_coords */ -vector3 from_geom_object_coords(vector3 p, geometric_object o) -{ +vector3 from_geom_object_coords(vector3 p, geometric_object o) { const vector3 half = {0.5, 0.5, 0.5}; p = vector3_minus(p, half); switch (o.which_subclass) { - default: - return o.center; - case GEOM SPHERE: - { + default: return o.center; + case GEOM SPHERE: { number radius = o.subclass.sphere_data->radius; return vector3_plus(o.center, vector3_scale(radius / 0.5, p)); } - /* case GEOM CYLINDER: - NOT YET IMPLEMENTED */ - case GEOM BLOCK: - { + /* case GEOM CYLINDER: + NOT YET IMPLEMENTED */ + case GEOM BLOCK: { vector3 size = o.subclass.block_data->size; return vector3_plus( - o.center, - vector3_plus( - vector3_scale(size.x * p.x, o.subclass.block_data->e1), - vector3_plus( - vector3_scale(size.y * p.y, o.subclass.block_data->e2), - vector3_scale(size.z * p.z, o.subclass.block_data->e3)) - )); + o.center, + vector3_plus(vector3_scale(size.x * p.x, o.subclass.block_data->e1), + vector3_plus(vector3_scale(size.y * p.y, o.subclass.block_data->e2), + vector3_scale(size.z * p.z, o.subclass.block_data->e3)))); } -/* case GEOM PRISM: - NOT YET IMPLEMENTED */ + /* case GEOM PRISM: + NOT YET IMPLEMENTED */ } } @@ -450,83 +396,73 @@ reasonable (at least for points near to the object). The length and sign of the normal vector are arbitrary. */ -vector3 CTLIO normal_to_object(vector3 p, geometric_object o) -{ - geom_fix_object_ptr(&o); - return normal_to_fixed_object(p, o); +vector3 CTLIO normal_to_object(vector3 p, geometric_object o) { + geom_fix_object_ptr(&o); + return normal_to_fixed_object(p, o); } -vector3 normal_to_fixed_object(vector3 p, geometric_object o) -{ - vector3 r = vector3_minus(p,o.center); +vector3 normal_to_fixed_object(vector3 p, geometric_object o) { + vector3 r = vector3_minus(p, o.center); switch (o.which_subclass) { - case GEOM CYLINDER: - { + case GEOM CYLINDER: { vector3 rm = matrix3x3_vector3_mult(geometry_lattice.metric, r); double proj = vector3_dot(o.subclass.cylinder_data->axis, rm), - height = o.subclass.cylinder_data->height, - radius, prad; - if (fabs(proj) > height * 0.5) - return o.subclass.cylinder_data->axis; + height = o.subclass.cylinder_data->height, radius, prad; + if (fabs(proj) > height * 0.5) return o.subclass.cylinder_data->axis; radius = o.subclass.cylinder_data->radius; - prad = sqrt(fabs(vector3_dot(r,rm) - proj*proj)); + prad = sqrt(fabs(vector3_dot(r, rm) - proj * proj)); if (o.subclass.cylinder_data->which_subclass == CYL CONE) - radius += (proj/height + 0.5) * - (o.subclass.cylinder_data->subclass.cone_data->radius2 - - radius); + radius += (proj / height + 0.5) * + (o.subclass.cylinder_data->subclass.cone_data->radius2 - radius); if (fabs(fabs(proj) - height * 0.5) < fabs(prad - radius)) - return o.subclass.cylinder_data->axis; + return o.subclass.cylinder_data->axis; if (o.subclass.cylinder_data->which_subclass == CYL CONE) - return vector3_minus(r, vector3_scale(proj + prad * (o.subclass.cylinder_data->subclass.cone_data->radius2 - radius) / height, o.subclass.cylinder_data->axis)); + return vector3_minus( + r, vector3_scale( + proj + prad * (o.subclass.cylinder_data->subclass.cone_data->radius2 - radius) / + height, + o.subclass.cylinder_data->axis)); else - return vector3_minus(r, vector3_scale(proj, o.subclass.cylinder_data->axis)); + return vector3_minus(r, vector3_scale(proj, o.subclass.cylinder_data->axis)); } // case GEOM CYLINDER - case GEOM BLOCK: - { - vector3 proj = - matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, r); + case GEOM BLOCK: { + vector3 proj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, r); switch (o.subclass.block_data->which_subclass) { - case BLK BLOCK_SELF: - { - vector3 size = o.subclass.block_data->size; - double d1 = fabs(fabs(proj.x) - 0.5 * size.x); - double d2 = fabs(fabs(proj.y) - 0.5 * size.y); - double d3 = fabs(fabs(proj.z) - 0.5 * size.z); - if (d1 < d2 && d1 < d3) - return matrix3x3_row1(o.subclass.block_data->projection_matrix); - else if (d2 < d3) - return matrix3x3_row2(o.subclass.block_data->projection_matrix); - else - return matrix3x3_row3(o.subclass.block_data->projection_matrix); - } // case BLK BLOCK_SELF - - case BLK ELLIPSOID: - default: - { - vector3 isa = - o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes; - proj.x *= isa.x * isa.x; - proj.y *= isa.y * isa.y; - proj.z *= isa.z * isa.z; - return matrix3x3_transpose_vector3_mult( - o.subclass.block_data->projection_matrix, proj); - } // case BLK ELLIPSOID + case BLK BLOCK_SELF: { + vector3 size = o.subclass.block_data->size; + double d1 = fabs(fabs(proj.x) - 0.5 * size.x); + double d2 = fabs(fabs(proj.y) - 0.5 * size.y); + double d3 = fabs(fabs(proj.z) - 0.5 * size.z); + if (d1 < d2 && d1 < d3) + return matrix3x3_row1(o.subclass.block_data->projection_matrix); + else if (d2 < d3) + return matrix3x3_row2(o.subclass.block_data->projection_matrix); + else + return matrix3x3_row3(o.subclass.block_data->projection_matrix); + } // case BLK BLOCK_SELF + + case BLK ELLIPSOID: + default: { + vector3 isa = o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes; + proj.x *= isa.x * isa.x; + proj.y *= isa.y * isa.y; + proj.z *= isa.z * isa.z; + return matrix3x3_transpose_vector3_mult(o.subclass.block_data->projection_matrix, proj); + } // case BLK ELLIPSOID } // switch (o.subclass.block_data->which_subclass) } // case GEOM BLOCK - case GEOM PRISM: - return normal_to_prism(o.subclass.prism_data, p); + case GEOM PRISM: return normal_to_prism(o.subclass.prism_data, p); - default: - return r; + default: return r; } // switch (o.which_subclass) - return r; // never get here + return r; // never get here } /**************************************************************************/ @@ -539,84 +475,73 @@ this easier to do as a macro. (One could at least wish for an easier way to make multi-line macros.) */ -#define LOOP_PERIODIC(shiftby, body) { \ - switch (dimensions) { \ - case 1: \ - { \ - int iii; \ - shiftby.y = shiftby.z = 0; \ - for (iii = -1; iii <= 1; ++iii) { \ - shiftby.x = iii * geometry_lattice.size.x; \ - body; \ - } \ - break; \ - } \ - case 2: \ - { \ - int iii, jjj; \ - shiftby.z = 0; \ - for (iii = -1; iii <= 1; ++iii) { \ - shiftby.x = iii * geometry_lattice.size.x; \ - for (jjj = -1; jjj <= 1; ++jjj) { \ - shiftby.y = jjj * geometry_lattice.size.y; \ - body; \ - } \ - } \ - break; \ - } \ - case 3: \ - { \ - int iii, jjj, kkk; \ - for (iii = -1; iii <= 1; ++iii) { \ - shiftby.x = iii * geometry_lattice.size.x; \ - for (jjj = -1; jjj <= 1; ++jjj) { \ - shiftby.y = jjj * geometry_lattice.size.y; \ - for (kkk = -1; kkk <= 1; ++kkk) { \ - shiftby.z = kkk * geometry_lattice.size.z; \ - body; \ - if (geometry_lattice.size.z == 0) break; \ - } \ - if (geometry_lattice.size.y == 0) break; \ - } \ - if (geometry_lattice.size.x == 0) break; \ - } \ - break; \ - } \ - } \ -} +#define LOOP_PERIODIC(shiftby, body) \ + { \ + switch (dimensions) { \ + case 1: { \ + int iii; \ + shiftby.y = shiftby.z = 0; \ + for (iii = -1; iii <= 1; ++iii) { \ + shiftby.x = iii * geometry_lattice.size.x; \ + body; \ + } \ + break; \ + } \ + case 2: { \ + int iii, jjj; \ + shiftby.z = 0; \ + for (iii = -1; iii <= 1; ++iii) { \ + shiftby.x = iii * geometry_lattice.size.x; \ + for (jjj = -1; jjj <= 1; ++jjj) { \ + shiftby.y = jjj * geometry_lattice.size.y; \ + body; \ + } \ + } \ + break; \ + } \ + case 3: { \ + int iii, jjj, kkk; \ + for (iii = -1; iii <= 1; ++iii) { \ + shiftby.x = iii * geometry_lattice.size.x; \ + for (jjj = -1; jjj <= 1; ++jjj) { \ + shiftby.y = jjj * geometry_lattice.size.y; \ + for (kkk = -1; kkk <= 1; ++kkk) { \ + shiftby.z = kkk * geometry_lattice.size.z; \ + body; \ + if (geometry_lattice.size.z == 0) break; \ + } \ + if (geometry_lattice.size.y == 0) break; \ + } \ + if (geometry_lattice.size.x == 0) break; \ + } \ + break; \ + } \ + } \ + } /**************************************************************************/ /* Like point_in_objectp, but also checks the object shifted by the lattice vectors: */ -boolean CTLIO point_in_periodic_objectp(vector3 p, geometric_object o) -{ - geom_fix_object_ptr(&o); - return point_in_periodic_fixed_objectp(p, o); -} - -boolean point_in_periodic_fixed_objectp(vector3 p, geometric_object o) -{ - vector3 shiftby; - LOOP_PERIODIC(shiftby, - if (point_in_fixed_objectp(vector3_minus(p, shiftby), o)) - return 1); - return 0; -} - -boolean point_shift_in_periodic_fixed_pobjectp(vector3 p, geometric_object *o, - vector3 *shiftby) -{ - geometric_object o0 = *o; - LOOP_PERIODIC((*shiftby), - { - *o = o0; - if (point_in_fixed_pobjectp( - vector3_minus(p, *shiftby), o)) - return 1; - }); - return 0; +boolean CTLIO point_in_periodic_objectp(vector3 p, geometric_object o) { + geom_fix_object_ptr(&o); + return point_in_periodic_fixed_objectp(p, o); +} + +boolean point_in_periodic_fixed_objectp(vector3 p, geometric_object o) { + vector3 shiftby; + LOOP_PERIODIC(shiftby, if (point_in_fixed_objectp(vector3_minus(p, shiftby), o)) return 1); + return 0; +} + +boolean point_shift_in_periodic_fixed_pobjectp(vector3 p, geometric_object *o, vector3 *shiftby) { + geometric_object o0 = *o; + LOOP_PERIODIC((*shiftby), { + *o = o0; + if (point_in_fixed_pobjectp(vector3_minus(p, *shiftby), o)) return 1; + }); + return 0; } /**************************************************************************/ @@ -634,156 +559,110 @@ material_of_point_inobject is a variant that also returns whether or not the point was in any object. */ -geometric_object object_of_point0(geometric_object_list geometry, vector3 p, - vector3 *shiftby) -{ - geometric_object o; - int index; - shiftby->x = shiftby->y = shiftby->z = 0; - /* loop in reverse order so that later items are given precedence: */ - for (index = geometry.num_items - 1; index >= 0; --index) { - o = geometry.items[index]; - if ((ensure_periodicity - && point_shift_in_periodic_fixed_pobjectp(p, &o, shiftby)) - || point_in_fixed_pobjectp(p, &o)) - return o; - } - o.which_subclass = GEOM GEOMETRIC_OBJECT_SELF; /* no object found */ - return o; -} - -geometric_object object_of_point(vector3 p, vector3 *shiftby) -{ - return object_of_point0(geometry, p, shiftby); -} - -material_type material_of_point_inobject0(geometric_object_list geometry, - vector3 p, boolean *inobject) -{ - vector3 shiftby; - geometric_object o = object_of_point0(geometry, p, &shiftby); - *inobject = o.which_subclass != GEOM GEOMETRIC_OBJECT_SELF;; - return (*inobject ? o.material : default_material); -} - -material_type material_of_point_inobject(vector3 p, boolean *inobject) -{ - return material_of_point_inobject0(geometry, p, inobject); -} - -material_type material_of_point0(geometric_object_list geometry, vector3 p) -{ - boolean inobject; - return material_of_point_inobject0(geometry, p, &inobject); -} - -material_type material_of_point(vector3 p) -{ - return material_of_point0(geometry, p); +geometric_object object_of_point0(geometric_object_list geometry, vector3 p, vector3 *shiftby) { + geometric_object o; + int index; + shiftby->x = shiftby->y = shiftby->z = 0; + /* loop in reverse order so that later items are given precedence: */ + for (index = geometry.num_items - 1; index >= 0; --index) { + o = geometry.items[index]; + if ((ensure_periodicity && point_shift_in_periodic_fixed_pobjectp(p, &o, shiftby)) || + point_in_fixed_pobjectp(p, &o)) + return o; + } + o.which_subclass = GEOM GEOMETRIC_OBJECT_SELF; /* no object found */ + return o; +} + +geometric_object object_of_point(vector3 p, vector3 *shiftby) { + return object_of_point0(geometry, p, shiftby); } +material_type material_of_point_inobject0(geometric_object_list geometry, vector3 p, + boolean *inobject) { + vector3 shiftby; + geometric_object o = object_of_point0(geometry, p, &shiftby); + *inobject = o.which_subclass != GEOM GEOMETRIC_OBJECT_SELF; + ; + return (*inobject ? o.material : default_material); +} + +material_type material_of_point_inobject(vector3 p, boolean *inobject) { + return material_of_point_inobject0(geometry, p, inobject); +} + +material_type material_of_point0(geometric_object_list geometry, vector3 p) { + boolean inobject; + return material_of_point_inobject0(geometry, p, &inobject); +} + +material_type material_of_point(vector3 p) { return material_of_point0(geometry, p); } + /**************************************************************************/ /* Given a geometric object o, display some information about it, indented by indentby spaces. */ -void CTLIO display_geometric_object_info(int indentby, geometric_object o) -{ - geom_fix_object_ptr(&o); - ctl_printf("%*s", indentby, ""); - switch (o.which_subclass) { - case GEOM CYLINDER: - switch (o.subclass.cylinder_data->which_subclass) { - case CYL WEDGE: - ctl_printf("wedge"); - break; - case CYL CONE: - ctl_printf("cone"); - break; - case CYL CYLINDER_SELF: - ctl_printf("cylinder"); - break; - } - break; - case GEOM SPHERE: - ctl_printf("sphere"); - break; - case GEOM BLOCK: - switch (o.subclass.block_data->which_subclass) { - case BLK ELLIPSOID: - ctl_printf("ellipsoid"); - break; - case BLK BLOCK_SELF: - ctl_printf("block"); - break; - } - break; - case GEOM PRISM: - ctl_printf("prism"); - break; - case GEOM COMPOUND_GEOMETRIC_OBJECT: - ctl_printf("compound object"); - break; - default: - ctl_printf("geometric object"); - break; - } - ctl_printf(", center = (%g,%g,%g)\n", - o.center.x, o.center.y, o.center.z); - switch (o.which_subclass) { - case GEOM CYLINDER: - ctl_printf("%*s radius %g, height %g, axis (%g, %g, %g)\n", - indentby, "", o.subclass.cylinder_data->radius, - o.subclass.cylinder_data->height, - o.subclass.cylinder_data->axis.x, - o.subclass.cylinder_data->axis.y, - o.subclass.cylinder_data->axis.z); - if (o.subclass.cylinder_data->which_subclass == CYL CONE) - ctl_printf("%*s radius2 %g\n", indentby, "", - o.subclass.cylinder_data->subclass.cone_data->radius2); - else if (o.subclass.cylinder_data->which_subclass == CYL WEDGE) - ctl_printf("%*s wedge-theta %g\n", indentby, "", - o.subclass.cylinder_data->subclass.wedge_data->wedge_angle); - break; - case GEOM SPHERE: - ctl_printf("%*s radius %g\n", indentby, "", - o.subclass.sphere_data->radius); - break; - case GEOM BLOCK: - ctl_printf("%*s size (%g,%g,%g)\n", indentby, "", - o.subclass.block_data->size.x, - o.subclass.block_data->size.y, - o.subclass.block_data->size.z); - ctl_printf("%*s axes (%g,%g,%g), (%g,%g,%g), (%g,%g,%g)\n", - indentby, "", - o.subclass.block_data->e1.x, - o.subclass.block_data->e1.y, - o.subclass.block_data->e1.z, - o.subclass.block_data->e2.x, - o.subclass.block_data->e2.y, - o.subclass.block_data->e2.z, - o.subclass.block_data->e3.x, - o.subclass.block_data->e3.y, - o.subclass.block_data->e3.z); - break; - case GEOM PRISM: - display_prism_info(indentby, &o); - break; - case GEOM COMPOUND_GEOMETRIC_OBJECT: - { - int i; - int n = o.subclass.compound_geometric_object_data - ->component_objects.num_items; - geometric_object *os = o.subclass.compound_geometric_object_data - ->component_objects.items; - ctl_printf("%*s %d components:\n", indentby, "", n); - for (i = 0; i < n; ++i) - display_geometric_object_info(indentby + 5, os[i]); - break; - } - default: - break; - } +void CTLIO display_geometric_object_info(int indentby, geometric_object o) { + geom_fix_object_ptr(&o); + ctl_printf("%*s", indentby, ""); + switch (o.which_subclass) { + case GEOM CYLINDER: + switch (o.subclass.cylinder_data->which_subclass) { + case CYL WEDGE: ctl_printf("wedge"); break; + case CYL CONE: ctl_printf("cone"); break; + case CYL CYLINDER_SELF: ctl_printf("cylinder"); break; + } + break; + case GEOM SPHERE: ctl_printf("sphere"); break; + case GEOM BLOCK: + switch (o.subclass.block_data->which_subclass) { + case BLK ELLIPSOID: ctl_printf("ellipsoid"); break; + case BLK BLOCK_SELF: ctl_printf("block"); break; + } + break; + case GEOM PRISM: ctl_printf("prism"); break; + case GEOM COMPOUND_GEOMETRIC_OBJECT: ctl_printf("compound object"); break; + default: ctl_printf("geometric object"); break; + } + ctl_printf(", center = (%g,%g,%g)\n", o.center.x, o.center.y, o.center.z); + switch (o.which_subclass) { + case GEOM CYLINDER: + ctl_printf("%*s radius %g, height %g, axis (%g, %g, %g)\n", indentby, "", + o.subclass.cylinder_data->radius, o.subclass.cylinder_data->height, + o.subclass.cylinder_data->axis.x, o.subclass.cylinder_data->axis.y, + o.subclass.cylinder_data->axis.z); + if (o.subclass.cylinder_data->which_subclass == CYL CONE) + ctl_printf("%*s radius2 %g\n", indentby, "", + o.subclass.cylinder_data->subclass.cone_data->radius2); + else if (o.subclass.cylinder_data->which_subclass == CYL WEDGE) + ctl_printf("%*s wedge-theta %g\n", indentby, "", + o.subclass.cylinder_data->subclass.wedge_data->wedge_angle); + break; + case GEOM SPHERE: + ctl_printf("%*s radius %g\n", indentby, "", o.subclass.sphere_data->radius); + break; + case GEOM BLOCK: + ctl_printf("%*s size (%g,%g,%g)\n", indentby, "", o.subclass.block_data->size.x, + o.subclass.block_data->size.y, o.subclass.block_data->size.z); + ctl_printf( + "%*s axes (%g,%g,%g), (%g,%g,%g), (%g,%g,%g)\n", indentby, "", + o.subclass.block_data->e1.x, o.subclass.block_data->e1.y, o.subclass.block_data->e1.z, + o.subclass.block_data->e2.x, o.subclass.block_data->e2.y, o.subclass.block_data->e2.z, + o.subclass.block_data->e3.x, o.subclass.block_data->e3.y, o.subclass.block_data->e3.z); + break; + case GEOM PRISM: display_prism_info(indentby, &o); break; + case GEOM COMPOUND_GEOMETRIC_OBJECT: { + int i; + int n = o.subclass.compound_geometric_object_data->component_objects.num_items; + geometric_object *os = o.subclass.compound_geometric_object_data->component_objects.items; + ctl_printf("%*s %d components:\n", indentby, "", n); + for (i = 0; i < n; ++i) + display_geometric_object_info(indentby + 5, os[i]); + break; + } + default: break; + } } /**************************************************************************/ @@ -791,194 +670,189 @@ /* Compute the intersections with o of a line along p+s*d, returning the number of intersections (at most 2) and the two intersection "s" values in s[0] and s[1]. (Note: o must not be a compound object.) */ -int intersect_line_with_object(vector3 p, vector3 d, geometric_object o, - double s[2]) -{ - p = vector3_minus(p, o.center); - s[0] = s[1] = 0; - switch (o.which_subclass) { - case GEOM SPHERE: { - number radius = o.subclass.sphere_data->radius; - vector3 dm = matrix3x3_vector3_mult(geometry_lattice.metric, d); - double a = vector3_dot(d, dm); - double b2 = -vector3_dot(dm, p); - double c = vector3_dot(p, matrix3x3_vector3_mult( - geometry_lattice.metric, p)) - radius * radius; - double discrim = b2*b2 - a*c; - if (discrim < 0) - return 0; - else if (discrim == 0) { - s[0] = b2 / a; - return 1; - } - else { - discrim = sqrt(discrim); - s[0] = (b2 + discrim) / a; - s[1] = (b2 - discrim) / a; - return 2; - } - } // case GEOM SPHERE - case GEOM CYLINDER: { - vector3 dm = matrix3x3_vector3_mult(geometry_lattice.metric, d); - vector3 pm = matrix3x3_vector3_mult(geometry_lattice.metric, p); - number height = o.subclass.cylinder_data->height; - number radius = o.subclass.cylinder_data->radius; - number radius2 = o.subclass.cylinder_data->which_subclass == CYL CONE ? o.subclass.cylinder_data->subclass.cone_data->radius2 : radius; - double dproj = vector3_dot(o.subclass.cylinder_data->axis, dm); - double pproj = vector3_dot(o.subclass.cylinder_data->axis, pm); - double D = (radius2 - radius) / height; - double L = radius + (radius2 - radius) * 0.5 + pproj*D; - double a = vector3_dot(d,dm) - dproj*dproj * (1 + D*D); - double b2 = dproj * (pproj + D*L) - vector3_dot(p,dm); - double c = vector3_dot(p,pm) - pproj*pproj - L*L; - double discrim = b2*b2 - a*c; - int ret; - if (a == 0) { /* linear equation */ - if (b2 == 0) { - if (c == 0) { /* infinite intersections */ - s[0] = ((height * 0.5) - pproj) / dproj; - s[1] = -((height * 0.5) + pproj) / dproj; - return 2; - } - else - ret = 0; - } - else { - s[0] = 0.5 * c / b2; - ret = 1; - } - } - else if (discrim < 0) - ret = 0; - else if (discrim == 0) { - s[0] = b2 / a; - ret = 1; - } - else { - discrim = sqrt(discrim); - s[0] = (b2 + discrim) / a; - s[1] = (b2 - discrim) / a; - ret = 2; - } - if (ret == 2 && fabs(pproj + s[1] * dproj) > height * 0.5) - ret = 1; - if (ret >= 1 && fabs(pproj + s[0] * dproj) > height * 0.5) { - --ret; - s[0] = s[1]; - } - if (ret == 2 || dproj == 0) - return ret; - /* find intersections with endcaps */ - s[ret] = (height * 0.5 - pproj) / dproj; - if (a * s[ret]*s[ret] - 2*b2 * s[ret] + c <= 0) - ++ret; - if (ret < 2) { - s[ret] = -(height * 0.5 + pproj) / dproj; - if (a * s[ret]*s[ret] - 2*b2 * s[ret] + c <= 0) - ++ret; - } - if (ret == 2 && s[0] == s[1]) ret = 1; - return ret; - } // case GEOM CYLINDER - case GEOM BLOCK: - { - vector3 dproj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, d); - vector3 pproj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, p); - switch (o.subclass.block_data->which_subclass) { - case BLK BLOCK_SELF: - { - vector3 size = o.subclass.block_data->size; - int ret = 0; - size.x *= 0.5; size.y *= 0.5; size.z *= 0.5; - if (dproj.x != 0) { - s[ret] = (size.x - pproj.x) / dproj.x; - if (fabs(pproj.y+s[ret]*dproj.y) <= size.y && - fabs(pproj.z+s[ret]*dproj.z) <= size.z) - ++ret; - s[ret] = (-size.x - pproj.x) / dproj.x; - if (fabs(pproj.y+s[ret]*dproj.y) <= size.y && - fabs(pproj.z+s[ret]*dproj.z) <= size.z) - ++ret; - if (ret == 2) return 2; - } - if (dproj.y != 0) { - s[ret] = (size.y - pproj.y) / dproj.y; - if (fabs(pproj.x+s[ret]*dproj.x) <= size.x && - fabs(pproj.z+s[ret]*dproj.z) <= size.z) - ++ret; - if (ret == 2) return 2; - s[ret] = (-size.y - pproj.y) / dproj.y; - if (fabs(pproj.x+s[ret]*dproj.x) <= size.x && - fabs(pproj.z+s[ret]*dproj.z) <= size.z) - ++ret; - if (ret == 2) return 2; - } - if (dproj.z != 0) { - s[ret] = (size.z - pproj.z) / dproj.z; - if (fabs(pproj.x+s[ret]*dproj.x) <= size.x && - fabs(pproj.y+s[ret]*dproj.y) <= size.y) - ++ret; - if (ret == 2) return 2; - s[ret] = (-size.z - pproj.z) / dproj.z; - if (fabs(pproj.x+s[ret]*dproj.x) <= size.x && - fabs(pproj.y+s[ret]*dproj.y) <= size.y) - ++ret; - } - return ret; - } // case BLK BLOCK_SELF: - - case BLK ELLIPSOID: - default: - { - vector3 isa = o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes; - double a, b2, c, discrim; - dproj.x *= isa.x; dproj.y *= isa.y; dproj.z *= isa.z; - pproj.x *= isa.x; pproj.y *= isa.y; pproj.z *= isa.z; - a = vector3_dot(dproj, dproj); - b2 = -vector3_dot(dproj, pproj); - c = vector3_dot(pproj, pproj) - 1; - discrim = b2*b2 - a*c; - if (discrim < 0) - return 0; - else if (discrim == 0) { - s[0] = b2 / a; - return 1; - } - else { - discrim = sqrt(discrim); - s[0] = (b2 + discrim) / a; - s[1] = (b2 - discrim) / a; - return 2; - } - } // case BLK BLOCK_SELF, default - - } // switch (o.subclass.block_data->which_subclass) - - } // case GEOM BLOCK - default: - return 0; - } +int intersect_line_with_object(vector3 p, vector3 d, geometric_object o, double s[2]) { + p = vector3_minus(p, o.center); + s[0] = s[1] = 0; + switch (o.which_subclass) { + case GEOM SPHERE: { + number radius = o.subclass.sphere_data->radius; + vector3 dm = matrix3x3_vector3_mult(geometry_lattice.metric, d); + double a = vector3_dot(d, dm); + double b2 = -vector3_dot(dm, p); + double c = + vector3_dot(p, matrix3x3_vector3_mult(geometry_lattice.metric, p)) - radius * radius; + double discrim = b2 * b2 - a * c; + if (discrim < 0) + return 0; + else if (discrim == 0) { + s[0] = b2 / a; + return 1; + } + else { + discrim = sqrt(discrim); + s[0] = (b2 + discrim) / a; + s[1] = (b2 - discrim) / a; + return 2; + } + } // case GEOM SPHERE + case GEOM CYLINDER: { + vector3 dm = matrix3x3_vector3_mult(geometry_lattice.metric, d); + vector3 pm = matrix3x3_vector3_mult(geometry_lattice.metric, p); + number height = o.subclass.cylinder_data->height; + number radius = o.subclass.cylinder_data->radius; + number radius2 = o.subclass.cylinder_data->which_subclass == CYL CONE + ? o.subclass.cylinder_data->subclass.cone_data->radius2 + : radius; + double dproj = vector3_dot(o.subclass.cylinder_data->axis, dm); + double pproj = vector3_dot(o.subclass.cylinder_data->axis, pm); + double D = (radius2 - radius) / height; + double L = radius + (radius2 - radius) * 0.5 + pproj * D; + double a = vector3_dot(d, dm) - dproj * dproj * (1 + D * D); + double b2 = dproj * (pproj + D * L) - vector3_dot(p, dm); + double c = vector3_dot(p, pm) - pproj * pproj - L * L; + double discrim = b2 * b2 - a * c; + int ret; + if (a == 0) { /* linear equation */ + if (b2 == 0) { + if (c == 0) { /* infinite intersections */ + s[0] = ((height * 0.5) - pproj) / dproj; + s[1] = -((height * 0.5) + pproj) / dproj; + return 2; + } + else + ret = 0; + } + else { + s[0] = 0.5 * c / b2; + ret = 1; + } + } + else if (discrim < 0) + ret = 0; + else if (discrim == 0) { + s[0] = b2 / a; + ret = 1; + } + else { + discrim = sqrt(discrim); + s[0] = (b2 + discrim) / a; + s[1] = (b2 - discrim) / a; + ret = 2; + } + if (ret == 2 && fabs(pproj + s[1] * dproj) > height * 0.5) ret = 1; + if (ret >= 1 && fabs(pproj + s[0] * dproj) > height * 0.5) { + --ret; + s[0] = s[1]; + } + if (ret == 2 || dproj == 0) return ret; + /* find intersections with endcaps */ + s[ret] = (height * 0.5 - pproj) / dproj; + if (a * s[ret] * s[ret] - 2 * b2 * s[ret] + c <= 0) ++ret; + if (ret < 2) { + s[ret] = -(height * 0.5 + pproj) / dproj; + if (a * s[ret] * s[ret] - 2 * b2 * s[ret] + c <= 0) ++ret; + } + if (ret == 2 && s[0] == s[1]) ret = 1; + return ret; + } // case GEOM CYLINDER + case GEOM BLOCK: { + vector3 dproj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, d); + vector3 pproj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, p); + switch (o.subclass.block_data->which_subclass) { + case BLK BLOCK_SELF: { + vector3 size = o.subclass.block_data->size; + int ret = 0; + size.x *= 0.5; + size.y *= 0.5; + size.z *= 0.5; + if (dproj.x != 0) { + s[ret] = (size.x - pproj.x) / dproj.x; + if (fabs(pproj.y + s[ret] * dproj.y) <= size.y && + fabs(pproj.z + s[ret] * dproj.z) <= size.z) + ++ret; + s[ret] = (-size.x - pproj.x) / dproj.x; + if (fabs(pproj.y + s[ret] * dproj.y) <= size.y && + fabs(pproj.z + s[ret] * dproj.z) <= size.z) + ++ret; + if (ret == 2) return 2; + } + if (dproj.y != 0) { + s[ret] = (size.y - pproj.y) / dproj.y; + if (fabs(pproj.x + s[ret] * dproj.x) <= size.x && + fabs(pproj.z + s[ret] * dproj.z) <= size.z) + ++ret; + if (ret == 2) return 2; + s[ret] = (-size.y - pproj.y) / dproj.y; + if (fabs(pproj.x + s[ret] * dproj.x) <= size.x && + fabs(pproj.z + s[ret] * dproj.z) <= size.z) + ++ret; + if (ret == 2) return 2; + } + if (dproj.z != 0) { + s[ret] = (size.z - pproj.z) / dproj.z; + if (fabs(pproj.x + s[ret] * dproj.x) <= size.x && + fabs(pproj.y + s[ret] * dproj.y) <= size.y) + ++ret; + if (ret == 2) return 2; + s[ret] = (-size.z - pproj.z) / dproj.z; + if (fabs(pproj.x + s[ret] * dproj.x) <= size.x && + fabs(pproj.y + s[ret] * dproj.y) <= size.y) + ++ret; + } + return ret; + } // case BLK BLOCK_SELF: + + case BLK ELLIPSOID: + default: { + vector3 isa = o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes; + double a, b2, c, discrim; + dproj.x *= isa.x; + dproj.y *= isa.y; + dproj.z *= isa.z; + pproj.x *= isa.x; + pproj.y *= isa.y; + pproj.z *= isa.z; + a = vector3_dot(dproj, dproj); + b2 = -vector3_dot(dproj, pproj); + c = vector3_dot(pproj, pproj) - 1; + discrim = b2 * b2 - a * c; + if (discrim < 0) + return 0; + else if (discrim == 0) { + s[0] = b2 / a; + return 1; + } + else { + discrim = sqrt(discrim); + s[0] = (b2 + discrim) / a; + s[1] = (b2 - discrim) / a; + return 2; + } + } // case BLK BLOCK_SELF, default + + } // switch (o.subclass.block_data->which_subclass) + + } // case GEOM BLOCK + default: return 0; + } } /* Compute the intersections with o of a line along p+s*d in the interval s in [a,b], returning the length of the s intersection in this interval. (Note: o must not be a compound object.) */ -double intersect_line_segment_with_object(vector3 p, vector3 d, geometric_object o, double a, double b) -{ - if (o.which_subclass==GEOM PRISM) - { - return intersect_line_segment_with_prism(o.subclass.prism_data, p, d, a, b); - } - else - { double s[2]; - if (2 == intersect_line_with_object(p, d, o, s)) - { double ds = (s[0] < s[1] ? MIN(s[1],b) - MAX(s[0],a) - : MIN(s[0],b) - MAX(s[1],a) - ); - return (ds > 0 ? ds : 0.0); - } - else +double intersect_line_segment_with_object(vector3 p, vector3 d, geometric_object o, double a, + double b) { + if (o.which_subclass == GEOM PRISM) { + return intersect_line_segment_with_prism(o.subclass.prism_data, p, d, a, b); + } + else { + double s[2]; + if (2 == intersect_line_with_object(p, d, o, s)) { + double ds = (s[0] < s[1] ? MIN(s[1], b) - MAX(s[0], a) : MIN(s[0], b) - MAX(s[1], a)); + return (ds > 0 ? ds : 0.0); + } + else return 0.0; - } + } } /**************************************************************************/ @@ -992,22 +866,16 @@ the square basis matrix will yield the coordinates of a point in the rectangular volume, given in the lattice basis. */ -matrix3x3 CTLIO square_basis(matrix3x3 basis, vector3 size) -{ +matrix3x3 CTLIO square_basis(matrix3x3 basis, vector3 size) { matrix3x3 square; square.c0 = basis.c0; - square.c1 = vector3_minus(basis.c1, vector3_scale(vector3_dot(basis.c0, - basis.c1), - basis.c1)); - - square.c2 = vector3_minus(basis.c2, vector3_scale(vector3_dot(basis.c0, - basis.c2), - basis.c2)); - square.c2 = vector3_minus(square.c2, vector3_scale(vector3_dot(basis.c0, - square.c2), - unit_vector3(square.c2))); + square.c1 = vector3_minus(basis.c1, vector3_scale(vector3_dot(basis.c0, basis.c1), basis.c1)); + + square.c2 = vector3_minus(basis.c2, vector3_scale(vector3_dot(basis.c0, basis.c2), basis.c2)); + square.c2 = vector3_minus( + square.c2, vector3_scale(vector3_dot(basis.c0, square.c2), unit_vector3(square.c2))); square.c0 = vector3_scale(size.x, square.c0); square.c1 = vector3_scale(size.y, square.c1); @@ -1020,47 +888,42 @@ /* compute the 3d volume enclosed by a geometric object o. */ -double geom_object_volume(GEOMETRIC_OBJECT o) -{ - switch (o.which_subclass) { - case GEOM SPHERE: { - number radius = o.subclass.sphere_data->radius; - return (1.333333333333333333 * K_PI) * radius*radius*radius; - } - case GEOM CYLINDER: { - number height = o.subclass.cylinder_data->height; - number radius = o.subclass.cylinder_data->radius; - number radius2 = o.subclass.cylinder_data->which_subclass == CYL CONE ? o.subclass.cylinder_data->subclass.cone_data->radius2 : radius; - double vol = height * (K_PI/3) * (radius*radius + radius*radius2 + radius2*radius2); - if (o.subclass.cylinder_data->which_subclass == CYL WEDGE) - return vol * fabs(o.subclass.cylinder_data->subclass.wedge_data->wedge_angle) / (2*K_PI); - else - return vol; - } - case GEOM BLOCK: { - vector3 size = o.subclass.block_data->size; - double vol = size.x * size.y * size.z * fabs(matrix3x3_determinant(geometry_lattice.basis) / matrix3x3_determinant(o.subclass.block_data->projection_matrix)); - return o.subclass.block_data->which_subclass == BLK BLOCK_SELF ? vol : vol * (K_PI/6); - } - case GEOM PRISM: { - vector3_list vertices = o.subclass.prism_data->vertices_p; - double area = 0; - int i; - for (i = 0; i < vertices.num_items; ++i) { - int i1 = (i + 1) % vertices.num_items; - area += 0.5 * (vertices.items[i1].x - vertices.items[i].x) * (vertices.items[i1].y + vertices.items[i].y); - } - return fabs(area) * o.subclass.prism_data->height; - } - default: - return 0; /* unsupported object types? */ - } +double geom_object_volume(GEOMETRIC_OBJECT o) { + switch (o.which_subclass) { + case GEOM SPHERE: { + number radius = o.subclass.sphere_data->radius; + return (1.333333333333333333 * K_PI) * radius * radius * radius; + } + case GEOM CYLINDER: { + number height = o.subclass.cylinder_data->height; + number radius = o.subclass.cylinder_data->radius; + number radius2 = o.subclass.cylinder_data->which_subclass == CYL CONE + ? o.subclass.cylinder_data->subclass.cone_data->radius2 + : radius; + double vol = height * (K_PI / 3) * (radius * radius + radius * radius2 + radius2 * radius2); + if (o.subclass.cylinder_data->which_subclass == CYL WEDGE) + return vol * fabs(o.subclass.cylinder_data->subclass.wedge_data->wedge_angle) / (2 * K_PI); + else + return vol; + } + case GEOM BLOCK: { + vector3 size = o.subclass.block_data->size; + double vol = size.x * size.y * size.z * + fabs(matrix3x3_determinant(geometry_lattice.basis) / + matrix3x3_determinant(o.subclass.block_data->projection_matrix)); + return o.subclass.block_data->which_subclass == BLK BLOCK_SELF ? vol : vol * (K_PI / 6); + } + case GEOM PRISM: { + return get_prism_volume(o.subclass.prism_data); + } + default: return 0; /* unsupported object types? */ + } } /**************************************************************************/ /**************************************************************************/ - /* Fast geometry routines */ +/* Fast geometry routines */ /* Using the above material_of_point routine is way too slow, especially when there are lots of objects to test. Thus, we develop the following @@ -1074,67 +937,55 @@ /**************************************************************************/ /* geom_box utilities: */ -static void geom_box_union(geom_box *bu, - const geom_box *b1, const geom_box *b2) -{ - bu->low.x = MIN(b1->low.x, b2->low.x); - bu->low.y = MIN(b1->low.y, b2->low.y); - bu->low.z = MIN(b1->low.z, b2->low.z); - bu->high.x = MAX(b1->high.x, b2->high.x); - bu->high.y = MAX(b1->high.y, b2->high.y); - bu->high.z = MAX(b1->high.z, b2->high.z); -} - -static void geom_box_intersection(geom_box *bi, - const geom_box *b1, - const geom_box *b2) -{ - bi->low.x = MAX(b1->low.x, b2->low.x); - bi->low.y = MAX(b1->low.y, b2->low.y); - bi->low.z = MAX(b1->low.z, b2->low.z); - bi->high.x = MIN(b1->high.x, b2->high.x); - bi->high.y = MIN(b1->high.y, b2->high.y); - bi->high.z = MIN(b1->high.z, b2->high.z); -} - -static void geom_box_add_pt(geom_box *b, vector3 p) -{ - b->low.x = MIN(b->low.x, p.x); - b->low.y = MIN(b->low.y, p.y); - b->low.z = MIN(b->low.z, p.z); - b->high.x = MAX(b->high.x, p.x); - b->high.y = MAX(b->high.y, p.y); - b->high.z = MAX(b->high.z, p.z); +static void geom_box_union(geom_box *bu, const geom_box *b1, const geom_box *b2) { + bu->low.x = MIN(b1->low.x, b2->low.x); + bu->low.y = MIN(b1->low.y, b2->low.y); + bu->low.z = MIN(b1->low.z, b2->low.z); + bu->high.x = MAX(b1->high.x, b2->high.x); + bu->high.y = MAX(b1->high.y, b2->high.y); + bu->high.z = MAX(b1->high.z, b2->high.z); +} + +static void geom_box_intersection(geom_box *bi, const geom_box *b1, const geom_box *b2) { + bi->low.x = MAX(b1->low.x, b2->low.x); + bi->low.y = MAX(b1->low.y, b2->low.y); + bi->low.z = MAX(b1->low.z, b2->low.z); + bi->high.x = MIN(b1->high.x, b2->high.x); + bi->high.y = MIN(b1->high.y, b2->high.y); + bi->high.z = MIN(b1->high.z, b2->high.z); +} + +static void geom_box_add_pt(geom_box *b, vector3 p) { + b->low.x = MIN(b->low.x, p.x); + b->low.y = MIN(b->low.y, p.y); + b->low.z = MIN(b->low.z, p.z); + b->high.x = MAX(b->high.x, p.x); + b->high.y = MAX(b->high.y, p.y); + b->high.z = MAX(b->high.z, p.z); } #define BETWEEN(x, low, high) ((x) >= (low) && (x) <= (high)) -static int geom_box_contains_point(const geom_box *b, vector3 p) -{ - return (BETWEEN(p.x, b->low.x, b->high.x) && - BETWEEN(p.y, b->low.y, b->high.y) && - BETWEEN(p.z, b->low.z, b->high.z)); +static int geom_box_contains_point(const geom_box *b, vector3 p) { + return (BETWEEN(p.x, b->low.x, b->high.x) && BETWEEN(p.y, b->low.y, b->high.y) && + BETWEEN(p.z, b->low.z, b->high.z)); } /* return whether or not the given two boxes intersect */ -static int geom_boxes_intersect(const geom_box *b1, const geom_box *b2) -{ - /* true if the x, y, and z ranges all intersect. */ - return ((BETWEEN(b1->low.x, b2->low.x, b2->high.x) || - BETWEEN(b1->high.x, b2->low.x, b2->high.x) || - BETWEEN(b2->low.x, b1->low.x, b1->high.x)) && - (BETWEEN(b1->low.y, b2->low.y, b2->high.y) || - BETWEEN(b1->high.y, b2->low.y, b2->high.y) || - BETWEEN(b2->low.y, b1->low.y, b1->high.y)) && - (BETWEEN(b1->low.z, b2->low.z, b2->high.z) || - BETWEEN(b1->high.z, b2->low.z, b2->high.z) || - BETWEEN(b2->low.z, b1->low.z, b1->high.z))); -} - -static void geom_box_shift(geom_box *b, vector3 shiftby) -{ - b->low = vector3_plus(b->low, shiftby); - b->high = vector3_plus(b->high, shiftby); +static int geom_boxes_intersect(const geom_box *b1, const geom_box *b2) { + /* true if the x, y, and z ranges all intersect. */ + return ( + (BETWEEN(b1->low.x, b2->low.x, b2->high.x) || BETWEEN(b1->high.x, b2->low.x, b2->high.x) || + BETWEEN(b2->low.x, b1->low.x, b1->high.x)) && + (BETWEEN(b1->low.y, b2->low.y, b2->high.y) || BETWEEN(b1->high.y, b2->low.y, b2->high.y) || + BETWEEN(b2->low.y, b1->low.y, b1->high.y)) && + (BETWEEN(b1->low.z, b2->low.z, b2->high.z) || BETWEEN(b1->high.z, b2->low.z, b2->high.z) || + BETWEEN(b2->low.z, b1->low.z, b1->high.z))); +} + +static void geom_box_shift(geom_box *b, vector3 shiftby) { + b->low = vector3_plus(b->low, shiftby); + b->high = vector3_plus(b->high, shiftby); } /**************************************************************************/ @@ -1142,10 +993,9 @@ /* Computing a bounding box for a geometric object: */ /* compute | (b x c) / (a * (b x c)) |, for use below */ -static number compute_dot_cross(vector3 a, vector3 b, vector3 c) -{ - vector3 bxc = vector3_cross(b, c); - return fabs(vector3_norm(bxc) / vector3_dot(a, bxc)); +static number compute_dot_cross(vector3 a, vector3 b, vector3 c) { + vector3 bxc = vector3_cross(b, c); + return fabs(vector3_norm(bxc) / vector3_dot(a, bxc)); } /* Compute a bounding box for the object o, preferably the smallest @@ -1155,158 +1005,132 @@ Requires that geometry_lattice global has been initialized, etcetera. */ -void geom_get_bounding_box(geometric_object o, geom_box *box) -{ - geom_fix_object_ptr(&o); - - /* initialize to empty box at the center of the object: */ - box->low = box->high = o.center; - - switch (o.which_subclass) { - case GEOM GEOMETRIC_OBJECT_SELF: - break; - case GEOM SPHERE: - { - /* Find the parallelepiped that the sphere inscribes. - The math comes out surpisingly simple--try it! */ - - number radius = o.subclass.sphere_data->radius; - /* actually, we could achieve the same effect here - by inverting the geometry_lattice.basis matrix... */ - number r1 = compute_dot_cross(geometry_lattice.b1, - geometry_lattice.b2, - geometry_lattice.b3) * radius; - number r2 = compute_dot_cross(geometry_lattice.b2, - geometry_lattice.b3, - geometry_lattice.b1) * radius; - number r3 = compute_dot_cross(geometry_lattice.b3, - geometry_lattice.b1, - geometry_lattice.b2) * radius; - box->low.x -= r1; - box->low.y -= r2; - box->low.z -= r3; - box->high.x += r1; - box->high.y += r2; - box->high.z += r3; - break; - } - case GEOM CYLINDER: - { - /* Find the bounding boxes of the two (circular) ends of - the cylinder, then take the union. Again, the math - for finding the bounding parallelepiped of a circle - comes out suprisingly simple in the end. Proof left - as an exercise for the reader. */ - - number radius = o.subclass.cylinder_data->radius; - number h = o.subclass.cylinder_data->height * 0.5; - vector3 axis = /* cylinder axis in cartesian coords */ - matrix3x3_vector3_mult(geometry_lattice.basis, - o.subclass.cylinder_data->axis); - vector3 e12 = vector3_cross(geometry_lattice.basis1, - geometry_lattice.basis2); - vector3 e23 = vector3_cross(geometry_lattice.basis2, - geometry_lattice.basis3); - vector3 e31 = vector3_cross(geometry_lattice.basis3, - geometry_lattice.basis1); - number elen2, eproj; - number r1, r2, r3; - geom_box tmp_box; - - /* Find bounding box dimensions, in lattice coords, - for the circular ends of the cylinder: */ - - elen2 = vector3_dot(e23, e23); - eproj = vector3_dot(e23, axis); - r1 = fabs(sqrt(fabs(elen2 - eproj*eproj)) / - vector3_dot(e23, geometry_lattice.b1)); - - elen2 = vector3_dot(e31, e31); - eproj = vector3_dot(e31, axis); - r2 = fabs(sqrt(fabs(elen2 - eproj*eproj)) / - vector3_dot(e31, geometry_lattice.b2)); - - elen2 = vector3_dot(e12, e12); - eproj = vector3_dot(e12, axis); - r3 = fabs(sqrt(fabs(elen2 - eproj*eproj)) / - vector3_dot(e12, geometry_lattice.b3)); - - /* Get axis in lattice coords: */ - axis = o.subclass.cylinder_data->axis; - - tmp_box = *box; /* set tmp_box to center of object */ - - /* bounding box for -h*axis cylinder end: */ - box->low.x -= h * axis.x + r1*radius; - box->low.y -= h * axis.y + r2*radius; - box->low.z -= h * axis.z + r3*radius; - box->high.x -= h * axis.x - r1*radius; - box->high.y -= h * axis.y - r2*radius; - box->high.z -= h * axis.z - r3*radius; - - if (o.subclass.cylinder_data->which_subclass == CYL CONE) - radius = - fabs(o.subclass.cylinder_data->subclass.cone_data->radius2); - - /* bounding box for +h*axis cylinder end: */ - tmp_box.low.x += h * axis.x - r1*radius; - tmp_box.low.y += h * axis.y - r2*radius; - tmp_box.low.z += h * axis.z - r3*radius; - tmp_box.high.x += h * axis.x + r1*radius; - tmp_box.high.y += h * axis.y + r2*radius; - tmp_box.high.z += h * axis.z + r3*radius; - - geom_box_union(box, box, &tmp_box); - break; - } - case GEOM BLOCK: - { - /* blocks are easy: just enlarge the box to be big enough to - contain all 8 corners of the block. */ - - vector3 s1 = vector3_scale(o.subclass.block_data->size.x, - o.subclass.block_data->e1); - vector3 s2 = vector3_scale(o.subclass.block_data->size.y, - o.subclass.block_data->e2); - vector3 s3 = vector3_scale(o.subclass.block_data->size.z, - o.subclass.block_data->e3); - vector3 corner = - vector3_plus(o.center, - vector3_scale(-0.5, - vector3_plus(s1, vector3_plus(s2, s3)))); - - geom_box_add_pt(box, corner); - geom_box_add_pt(box, vector3_plus(corner, s1)); - geom_box_add_pt(box, vector3_plus(corner, s2)); - geom_box_add_pt(box, vector3_plus(corner, s3)); - geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s1, s2))); - geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s1, s3))); - geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s3, s2))); - geom_box_add_pt(box, - vector3_plus(corner, vector3_plus(s1, vector3_plus(s2, s3)))); - break; - } - case GEOM PRISM: - { - get_prism_bounding_box(o.subclass.prism_data, box); - break; - } - case GEOM COMPOUND_GEOMETRIC_OBJECT: - { - int i; - int n = o.subclass.compound_geometric_object_data - ->component_objects.num_items; - geometric_object *os = o.subclass.compound_geometric_object_data - ->component_objects.items; - for (i = 0; i < n; ++i) { - geom_box boxi; - geom_get_bounding_box(os[i], &boxi); - geom_box_shift(&boxi, o.center); - geom_box_union(box, box, &boxi); - } - break; - } - } +void geom_get_bounding_box(geometric_object o, geom_box *box) { + geom_fix_object_ptr(&o); + + /* initialize to empty box at the center of the object: */ + box->low = box->high = o.center; + + switch (o.which_subclass) { + case GEOM GEOMETRIC_OBJECT_SELF: break; + case GEOM SPHERE: { + /* Find the parallelepiped that the sphere inscribes. + The math comes out surpisingly simple--try it! */ + + number radius = o.subclass.sphere_data->radius; + /* actually, we could achieve the same effect here + by inverting the geometry_lattice.basis matrix... */ + number r1 = + compute_dot_cross(geometry_lattice.b1, geometry_lattice.b2, geometry_lattice.b3) * radius; + number r2 = + compute_dot_cross(geometry_lattice.b2, geometry_lattice.b3, geometry_lattice.b1) * radius; + number r3 = + compute_dot_cross(geometry_lattice.b3, geometry_lattice.b1, geometry_lattice.b2) * radius; + box->low.x -= r1; + box->low.y -= r2; + box->low.z -= r3; + box->high.x += r1; + box->high.y += r2; + box->high.z += r3; + break; + } + case GEOM CYLINDER: { + /* Find the bounding boxes of the two (circular) ends of + the cylinder, then take the union. Again, the math + for finding the bounding parallelepiped of a circle + comes out suprisingly simple in the end. Proof left + as an exercise for the reader. */ + + number radius = o.subclass.cylinder_data->radius; + number h = o.subclass.cylinder_data->height * 0.5; + vector3 axis = /* cylinder axis in cartesian coords */ + matrix3x3_vector3_mult(geometry_lattice.basis, o.subclass.cylinder_data->axis); + vector3 e12 = vector3_cross(geometry_lattice.basis1, geometry_lattice.basis2); + vector3 e23 = vector3_cross(geometry_lattice.basis2, geometry_lattice.basis3); + vector3 e31 = vector3_cross(geometry_lattice.basis3, geometry_lattice.basis1); + number elen2, eproj; + number r1, r2, r3; + geom_box tmp_box; + + /* Find bounding box dimensions, in lattice coords, + for the circular ends of the cylinder: */ + + elen2 = vector3_dot(e23, e23); + eproj = vector3_dot(e23, axis); + r1 = fabs(sqrt(fabs(elen2 - eproj * eproj)) / vector3_dot(e23, geometry_lattice.b1)); + + elen2 = vector3_dot(e31, e31); + eproj = vector3_dot(e31, axis); + r2 = fabs(sqrt(fabs(elen2 - eproj * eproj)) / vector3_dot(e31, geometry_lattice.b2)); + + elen2 = vector3_dot(e12, e12); + eproj = vector3_dot(e12, axis); + r3 = fabs(sqrt(fabs(elen2 - eproj * eproj)) / vector3_dot(e12, geometry_lattice.b3)); + + /* Get axis in lattice coords: */ + axis = o.subclass.cylinder_data->axis; + + tmp_box = *box; /* set tmp_box to center of object */ + + /* bounding box for -h*axis cylinder end: */ + box->low.x -= h * axis.x + r1 * radius; + box->low.y -= h * axis.y + r2 * radius; + box->low.z -= h * axis.z + r3 * radius; + box->high.x -= h * axis.x - r1 * radius; + box->high.y -= h * axis.y - r2 * radius; + box->high.z -= h * axis.z - r3 * radius; + + if (o.subclass.cylinder_data->which_subclass == CYL CONE) + radius = fabs(o.subclass.cylinder_data->subclass.cone_data->radius2); + + /* bounding box for +h*axis cylinder end: */ + tmp_box.low.x += h * axis.x - r1 * radius; + tmp_box.low.y += h * axis.y - r2 * radius; + tmp_box.low.z += h * axis.z - r3 * radius; + tmp_box.high.x += h * axis.x + r1 * radius; + tmp_box.high.y += h * axis.y + r2 * radius; + tmp_box.high.z += h * axis.z + r3 * radius; + + geom_box_union(box, box, &tmp_box); + break; + } + case GEOM BLOCK: { + /* blocks are easy: just enlarge the box to be big enough to + contain all 8 corners of the block. */ + + vector3 s1 = vector3_scale(o.subclass.block_data->size.x, o.subclass.block_data->e1); + vector3 s2 = vector3_scale(o.subclass.block_data->size.y, o.subclass.block_data->e2); + vector3 s3 = vector3_scale(o.subclass.block_data->size.z, o.subclass.block_data->e3); + vector3 corner = + vector3_plus(o.center, vector3_scale(-0.5, vector3_plus(s1, vector3_plus(s2, s3)))); + + geom_box_add_pt(box, corner); + geom_box_add_pt(box, vector3_plus(corner, s1)); + geom_box_add_pt(box, vector3_plus(corner, s2)); + geom_box_add_pt(box, vector3_plus(corner, s3)); + geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s1, s2))); + geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s1, s3))); + geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s3, s2))); + geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s1, vector3_plus(s2, s3)))); + break; + } + case GEOM PRISM: { + get_prism_bounding_box(o.subclass.prism_data, box); + break; + } + case GEOM COMPOUND_GEOMETRIC_OBJECT: { + int i; + int n = o.subclass.compound_geometric_object_data->component_objects.num_items; + geometric_object *os = o.subclass.compound_geometric_object_data->component_objects.items; + for (i = 0; i < n; ++i) { + geom_box boxi; + geom_get_bounding_box(os[i], &boxi); + geom_box_shift(&boxi, o.center); + geom_box_union(box, box, &boxi); + } + break; + } + } } /**************************************************************************/ @@ -1316,222 +1140,213 @@ orthogonal). */ typedef struct { - geometric_object o; - vector3 p, dir; - int pdim[2]; /* the (up to two) integration directions */ - double scx[2]; /* scale factor (e.g. sign flip) for x coordinates */ - unsigned dim; - double a0, b0; /* box limits along analytic direction */ - int is_ellipsoid; /* 0 for box, 1 for ellipsoid */ - double winv[2], c[2]; /* ellipsoid width-inverses/centers in int. dirs */ - double w0, c0; /* width/center along analytic direction */ + geometric_object o; + vector3 p, dir; + int pdim[2]; /* the (up to two) integration directions */ + double scx[2]; /* scale factor (e.g. sign flip) for x coordinates */ + unsigned dim; + double a0, b0; /* box limits along analytic direction */ + int is_ellipsoid; /* 0 for box, 1 for ellipsoid */ + double winv[2], c[2]; /* ellipsoid width-inverses/centers in int. dirs */ + double w0, c0; /* width/center along analytic direction */ } overlap_data; -static double overlap_integrand(integer ndim, number *x, void *data_) -{ - overlap_data *data = (overlap_data *) data_; - double s[2]; - const double *scx = data->scx; - vector3 p = data->p; - double a0 = data->a0, b0 = data->b0; - double scale_result = 1.0; - - if (ndim > 0) { - switch (data->pdim[0]) { - case 0: p.x = scx[0] * x[0]; break; - case 1: p.y = scx[0] * x[0]; break; - case 2: p.z = scx[0] * x[0]; break; - } - if (ndim > 1) { - switch (data->pdim[1]) { - case 0: p.x = scx[1] * x[1]; break; - case 1: p.y = scx[1] * x[1]; break; - case 2: p.z = scx[1] * x[1]; break; - } - } - } - - if (data->is_ellipsoid && ndim > 0) { - /* compute width of ellipsoid at this point, along the - analytic-intersection direction */ - double dx = (x[0] - data->c[0]) * data->winv[0]; - double w = 1.0 - dx * dx; - if (ndim > 1) { /* rescale 2nd dimension to stay inside ellipsoid */ - double x1; - if (w < 0) return 0.0; /* outside the ellipsoid */ - scale_result = sqrt(w); - x1 = data->c[1] + (x[1] - data->c[1]) * scale_result; - switch (data->pdim[1]) { - case 0: p.x = scx[1] * x1; break; - case 1: p.y = scx[1] * x1; break; - case 2: p.z = scx[1] * x1; break; - } - dx = (x1 - data->c[1]) * data->winv[1]; - w -= dx * dx; - } - if (w < 0) return 0.0; /* outside the ellipsoid */ - w = data->w0 * sqrt(w); - a0 = data->c0 - w; b0 = data->c0 + w; - } - - return intersect_line_segment_with_object(p, data->dir, data->o, a0, b0) * scale_result; -} - -number overlap_with_object(geom_box b, int is_ellipsoid, geometric_object o, - number tol, integer maxeval) -{ - overlap_data data; - int empty_x = b.low.x == b.high.x; - int empty_y = b.low.y == b.high.y; - int empty_z = b.low.z == b.high.z; - double V0 = ((empty_x ? 1 : b.high.x - b.low.x) * - (empty_y ? 1 : b.high.y - b.low.y) * - (empty_z ? 1 : b.high.z - b.low.z)); - vector3 ex = {1,0,0}, ey = {0,1,0}, ez = {0,0,1}; - geom_box bb; - double xmin[2] = {0,0}, xmax[2] = {0,0}, esterr; - int errflag; - unsigned i; - - geom_get_bounding_box(o, &bb); - if (!is_ellipsoid && - !empty_x && !empty_y && !empty_z && /* todo: optimize 1d and 2d cases */ - bb.low.x >= b.low.x && bb.high.x <= b.high.x && - bb.low.y >= b.low.y && bb.high.y <= b.high.y && - bb.low.z >= b.low.z && bb.high.z <= b.high.z) - return geom_object_volume(o) / (V0 * fabs(matrix3x3_determinant(geometry_lattice.basis))); /* o is completely contained within b */ - geom_box_intersection(&bb, &b, &bb); - if (bb.low.x > bb.high.x || bb.low.y > bb.high.y || bb.low.z > bb.high.z - || (!empty_x && bb.low.x == bb.high.x) - || (!empty_y && bb.low.y == bb.high.y) - || (!empty_z && bb.low.z == bb.high.z)) - return 0.0; - - data.winv[0] = data.winv[1] = data.w0 = 1.0; - data.c[0] = data.c[1] = data.c0 = 0; - - data.o = o; - data.p.x = data.p.y = data.p.z = 0; - data.dim = 0; - if (!empty_x) { - data.dir = ex; - data.a0 = bb.low.x; - data.b0 = bb.high.x; - data.w0 = 0.5 * (b.high.x - b.low.x); - data.c0 = 0.5 * (b.high.x + b.low.x); - if (!empty_y) { - xmin[data.dim] = bb.low.y; - xmax[data.dim] = bb.high.y; - data.winv[data.dim] = 2.0 / (b.high.y - b.low.y); - data.c[data.dim] = 0.5 * (b.high.y + b.low.y); - data.pdim[data.dim++] = 1; - } - if (!empty_z) { - xmin[data.dim] = bb.low.z; - xmax[data.dim] = bb.high.z; - data.winv[data.dim] = 2.0 / (b.high.z - b.low.z); - data.c[data.dim] = 0.5 * (b.high.z + b.low.z); - data.pdim[data.dim++] = 2; - } - } - else if (!empty_y) { - data.dir = ey; - data.a0 = bb.low.y; - data.b0 = bb.high.y; - data.w0 = 0.5 * (b.high.y - b.low.y); - data.c0 = 0.5 * (b.high.y + b.low.y); - if (!empty_x) { - xmin[data.dim] = bb.low.x; - xmax[data.dim] = bb.high.x; - data.winv[data.dim] = 2.0 / (b.high.x - b.low.x); - data.c[data.dim] = 0.5 * (b.high.x + b.low.x); - data.pdim[data.dim++] = 0; - } - if (!empty_z) { - xmin[data.dim] = bb.low.z; - xmax[data.dim] = bb.high.z; - data.winv[data.dim] = 2.0 / (b.high.z - b.low.z); - data.c[data.dim] = 0.5 * (b.high.z + b.low.z); - data.pdim[data.dim++] = 2; - } - } - else if (!empty_z) { - data.dir = ez; - data.a0 = bb.low.z; - data.b0 = bb.high.z; - data.w0 = 0.5 * (b.high.z - b.low.z); - data.c0 = 0.5 * (b.high.z + b.low.z); - if (!empty_x) { - xmin[data.dim] = bb.low.x; - xmax[data.dim] = bb.high.x; - data.winv[data.dim] = 2.0 / (b.high.x - b.low.x); - data.c[data.dim] = 0.5 * (b.high.x + b.low.x); - data.pdim[data.dim++] = 0; - } - if (!empty_y) { - xmin[data.dim] = bb.low.y; - xmax[data.dim] = bb.high.y; - data.winv[data.dim] = 2.0 / (b.high.y - b.low.y); - data.c[data.dim] = 0.5 * (b.high.y + b.low.y); - data.pdim[data.dim++] = 1; - } - } - else - return 1.0; +static double overlap_integrand(integer ndim, number *x, void *data_) { + overlap_data *data = (overlap_data *)data_; + double s[2]; + const double *scx = data->scx; + vector3 p = data->p; + double a0 = data->a0, b0 = data->b0; + double scale_result = 1.0; + + if (ndim > 0) { + switch (data->pdim[0]) { + case 0: p.x = scx[0] * x[0]; break; + case 1: p.y = scx[0] * x[0]; break; + case 2: p.z = scx[0] * x[0]; break; + } + if (ndim > 1) { + switch (data->pdim[1]) { + case 0: p.x = scx[1] * x[1]; break; + case 1: p.y = scx[1] * x[1]; break; + case 2: p.z = scx[1] * x[1]; break; + } + } + } + + if (data->is_ellipsoid && ndim > 0) { + /* compute width of ellipsoid at this point, along the + analytic-intersection direction */ + double dx = (x[0] - data->c[0]) * data->winv[0]; + double w = 1.0 - dx * dx; + if (ndim > 1) { /* rescale 2nd dimension to stay inside ellipsoid */ + double x1; + if (w < 0) return 0.0; /* outside the ellipsoid */ + scale_result = sqrt(w); + x1 = data->c[1] + (x[1] - data->c[1]) * scale_result; + switch (data->pdim[1]) { + case 0: p.x = scx[1] * x1; break; + case 1: p.y = scx[1] * x1; break; + case 2: p.z = scx[1] * x1; break; + } + dx = (x1 - data->c[1]) * data->winv[1]; + w -= dx * dx; + } + if (w < 0) return 0.0; /* outside the ellipsoid */ + w = data->w0 * sqrt(w); + a0 = data->c0 - w; + b0 = data->c0 + w; + } + + return intersect_line_segment_with_object(p, data->dir, data->o, a0, b0) * scale_result; +} + +number overlap_with_object(geom_box b, int is_ellipsoid, geometric_object o, number tol, + integer maxeval) { + overlap_data data; + int empty_x = b.low.x == b.high.x; + int empty_y = b.low.y == b.high.y; + int empty_z = b.low.z == b.high.z; + double V0 = ((empty_x ? 1 : b.high.x - b.low.x) * (empty_y ? 1 : b.high.y - b.low.y) * + (empty_z ? 1 : b.high.z - b.low.z)); + vector3 ex = {1, 0, 0}, ey = {0, 1, 0}, ez = {0, 0, 1}; + geom_box bb; + double xmin[2] = {0, 0}, xmax[2] = {0, 0}, esterr; + int errflag; + unsigned i; + + geom_get_bounding_box(o, &bb); + if (!is_ellipsoid && !empty_x && !empty_y && !empty_z && /* todo: optimize 1d and 2d cases */ + bb.low.x >= b.low.x && bb.high.x <= b.high.x && bb.low.y >= b.low.y && + bb.high.y <= b.high.y && bb.low.z >= b.low.z && bb.high.z <= b.high.z) + return geom_object_volume(o) / + (V0 * fabs(matrix3x3_determinant( + geometry_lattice.basis))); /* o is completely contained within b */ + geom_box_intersection(&bb, &b, &bb); + if (bb.low.x > bb.high.x || bb.low.y > bb.high.y || bb.low.z > bb.high.z || + (!empty_x && bb.low.x == bb.high.x) || (!empty_y && bb.low.y == bb.high.y) || + (!empty_z && bb.low.z == bb.high.z)) + return 0.0; + + data.winv[0] = data.winv[1] = data.w0 = 1.0; + data.c[0] = data.c[1] = data.c0 = 0; + + data.o = o; + data.p.x = data.p.y = data.p.z = 0; + data.dim = 0; + if (!empty_x) { + data.dir = ex; + data.a0 = bb.low.x; + data.b0 = bb.high.x; + data.w0 = 0.5 * (b.high.x - b.low.x); + data.c0 = 0.5 * (b.high.x + b.low.x); + if (!empty_y) { + xmin[data.dim] = bb.low.y; + xmax[data.dim] = bb.high.y; + data.winv[data.dim] = 2.0 / (b.high.y - b.low.y); + data.c[data.dim] = 0.5 * (b.high.y + b.low.y); + data.pdim[data.dim++] = 1; + } + if (!empty_z) { + xmin[data.dim] = bb.low.z; + xmax[data.dim] = bb.high.z; + data.winv[data.dim] = 2.0 / (b.high.z - b.low.z); + data.c[data.dim] = 0.5 * (b.high.z + b.low.z); + data.pdim[data.dim++] = 2; + } + } + else if (!empty_y) { + data.dir = ey; + data.a0 = bb.low.y; + data.b0 = bb.high.y; + data.w0 = 0.5 * (b.high.y - b.low.y); + data.c0 = 0.5 * (b.high.y + b.low.y); + if (!empty_x) { + xmin[data.dim] = bb.low.x; + xmax[data.dim] = bb.high.x; + data.winv[data.dim] = 2.0 / (b.high.x - b.low.x); + data.c[data.dim] = 0.5 * (b.high.x + b.low.x); + data.pdim[data.dim++] = 0; + } + if (!empty_z) { + xmin[data.dim] = bb.low.z; + xmax[data.dim] = bb.high.z; + data.winv[data.dim] = 2.0 / (b.high.z - b.low.z); + data.c[data.dim] = 0.5 * (b.high.z + b.low.z); + data.pdim[data.dim++] = 2; + } + } + else if (!empty_z) { + data.dir = ez; + data.a0 = bb.low.z; + data.b0 = bb.high.z; + data.w0 = 0.5 * (b.high.z - b.low.z); + data.c0 = 0.5 * (b.high.z + b.low.z); + if (!empty_x) { + xmin[data.dim] = bb.low.x; + xmax[data.dim] = bb.high.x; + data.winv[data.dim] = 2.0 / (b.high.x - b.low.x); + data.c[data.dim] = 0.5 * (b.high.x + b.low.x); + data.pdim[data.dim++] = 0; + } + if (!empty_y) { + xmin[data.dim] = bb.low.y; + xmax[data.dim] = bb.high.y; + data.winv[data.dim] = 2.0 / (b.high.y - b.low.y); + data.c[data.dim] = 0.5 * (b.high.y + b.low.y); + data.pdim[data.dim++] = 1; + } + } + else + return 1.0; #if 1 - /* To maintain mirror symmetries through the x/y/z axes, we flip - the integration range whenever xmax < 0. (This is in case - the integration routine is not fully symmetric, which may - happen(?) due to the upper bound on the #evaluations.)*/ - for (i = 0; i < data.dim; ++i) { - if (xmax[i] < 0) { - double xm = xmin[i]; - data.scx[i] = -1; - xmin[i] = -xmax[i]; - xmax[i] = -xm; - data.c[i] = -data.c[i]; - } - else - data.scx[i] = 1; - } + /* To maintain mirror symmetries through the x/y/z axes, we flip + the integration range whenever xmax < 0. (This is in case + the integration routine is not fully symmetric, which may + happen(?) due to the upper bound on the #evaluations.)*/ + for (i = 0; i < data.dim; ++i) { + if (xmax[i] < 0) { + double xm = xmin[i]; + data.scx[i] = -1; + xmin[i] = -xmax[i]; + xmax[i] = -xm; + data.c[i] = -data.c[i]; + } + else + data.scx[i] = 1; + } #else - for (i = 0; i < data.dim; ++i) data.scx[i] = 1; + for (i = 0; i < data.dim; ++i) + data.scx[i] = 1; #endif - if ((data.is_ellipsoid = is_ellipsoid)) { /* data for ellipsoid calc. */ - if (data.dim == 1) - V0 *= K_PI / 4; - else if (data.dim == 2) - V0 *= K_PI / 6; - } - - return adaptive_integration(overlap_integrand, xmin, xmax, - data.dim, &data, - 0.0, tol, maxeval, - &esterr, &errflag) / V0; -} - -number box_overlap_with_object(geom_box b, geometric_object o, - number tol, integer maxeval) -{ - return overlap_with_object(b, 0, o, tol, maxeval); -} - -number ellipsoid_overlap_with_object(geom_box b, geometric_object o, - number tol, integer maxeval) -{ - return overlap_with_object(b, 1, o, tol, maxeval); -} - -number CTLIO range_overlap_with_object(vector3 low, vector3 high, - geometric_object o, number tol, - integer maxeval) -{ - geom_box b; - b.low = low; - b.high = high; - return box_overlap_with_object(b, o, tol, maxeval); + if ((data.is_ellipsoid = is_ellipsoid)) { /* data for ellipsoid calc. */ + if (data.dim == 1) + V0 *= K_PI / 4; + else if (data.dim == 2) + V0 *= K_PI / 6; + } + + return adaptive_integration(overlap_integrand, xmin, xmax, data.dim, &data, 0.0, tol, maxeval, + &esterr, &errflag) / + V0; +} + +number box_overlap_with_object(geom_box b, geometric_object o, number tol, integer maxeval) { + return overlap_with_object(b, 0, o, tol, maxeval); +} + +number ellipsoid_overlap_with_object(geom_box b, geometric_object o, number tol, integer maxeval) { + return overlap_with_object(b, 1, o, tol, maxeval); +} + +number CTLIO range_overlap_with_object(vector3 low, vector3 high, geometric_object o, number tol, + integer maxeval) { + geom_box b; + b.low = low; + b.high = high; + return box_overlap_with_object(b, o, tol, maxeval); } /**************************************************************************/ @@ -1540,337 +1355,291 @@ them. The tree recursively partitions the unit cell, allowing us to perform binary searches for the object containing a given point. */ -void destroy_geom_box_tree(geom_box_tree t) -{ - if (t) { - destroy_geom_box_tree(t->t1); - destroy_geom_box_tree(t->t2); - if (t->nobjects && t->objects) - FREE(t->objects); - FREE1(t); - } +void destroy_geom_box_tree(geom_box_tree t) { + if (t) { + destroy_geom_box_tree(t->t1); + destroy_geom_box_tree(t->t2); + if (t->nobjects && t->objects) FREE(t->objects); + FREE1(t); + } } /* return whether the object o, shifted by the vector shiftby, possibly intersects b. Upon return, obj_b is the bounding box for o. */ -static int object_in_box(geometric_object o, vector3 shiftby, - geom_box *obj_b, const geom_box *b) -{ - geom_get_bounding_box(o, obj_b); - geom_box_shift(obj_b, shiftby); - return geom_boxes_intersect(obj_b, b); -} - -static geom_box_tree new_geom_box_tree(void) -{ - geom_box_tree t; - - t = MALLOC1(struct geom_box_tree_struct); - CHECK(t, "out of memory"); - t->t1 = t->t2 = NULL; - t->nobjects = 0; - t->objects = NULL; - return t; +static int object_in_box(geometric_object o, vector3 shiftby, geom_box *obj_b, const geom_box *b) { + geom_get_bounding_box(o, obj_b); + geom_box_shift(obj_b, shiftby); + return geom_boxes_intersect(obj_b, b); +} + +static geom_box_tree new_geom_box_tree(void) { + geom_box_tree t; + + t = MALLOC1(struct geom_box_tree_struct); + CHECK(t, "out of memory"); + t->t1 = t->t2 = NULL; + t->nobjects = 0; + t->objects = NULL; + return t; } /* Divide b into b1 and b2, cutting b in two along the axis divide_axis (0 = x, 1 = y, 2 = z) at divide_point. */ -static void divide_geom_box(const geom_box *b, - int divide_axis, number divide_point, - geom_box *b1, geom_box *b2) -{ - *b1 = *b2 = *b; - switch (divide_axis) { - case 0: - b1->high.x = b2->low.x = divide_point; - break; - case 1: - b1->high.y = b2->low.y = divide_point; - break; - case 2: - b1->high.z = b2->low.z = divide_point; - break; - } +static void divide_geom_box(const geom_box *b, int divide_axis, number divide_point, geom_box *b1, + geom_box *b2) { + *b1 = *b2 = *b; + switch (divide_axis) { + case 0: b1->high.x = b2->low.x = divide_point; break; + case 1: b1->high.y = b2->low.y = divide_point; break; + case 2: b1->high.z = b2->low.z = divide_point; break; + } } -#define VEC_I(v,i) ((i) == 0 ? (v).x : ((i) == 1 ? (v).y : (v).z)) +#define VEC_I(v, i) ((i) == 0 ? (v).x : ((i) == 1 ? (v).y : (v).z)) #define SMALL 1.0e-7 /* Find the best place (best_partition) to "cut" along the axis divide_axis in order to maximally divide the objects between the partitions. Upon return, n1 and n2 are the number of objects below and above the partition, respectively. */ -static void find_best_partition(int nobjects, const geom_box_object *objects, - int divide_axis, - number *best_partition, int *n1, int *n2) -{ - number cur_partition; - int i, j, cur_n1, cur_n2; - - *n1 = *n2 = nobjects + 1; - *best_partition = 0; - - /* Search for the best partition, by checking all possible partitions - either just above the high end of an object or just below the - low end of an object. */ - - for (i = 0; i < nobjects; ++i) { - cur_partition = VEC_I(objects[i].box.high, divide_axis) * (1 + SMALL); - cur_n1 = cur_n2 = 0; - for (j = 0; j < nobjects; ++j) { - double low = VEC_I(objects[j].box.low, divide_axis); - double high = VEC_I(objects[j].box.high, divide_axis); - cur_n1 += low <= cur_partition; - cur_n2 += high >= cur_partition; - } - CHECK(cur_n1 + cur_n2 >= nobjects, "assertion failure 1 in find_best_partition"); - if (MAX(cur_n1, cur_n2) < MAX(*n1, *n2)) { - *best_partition = cur_partition; - *n1 = cur_n1; - *n2 = cur_n2; - } - } - for (i = 0; i < nobjects; ++i) { - cur_partition = VEC_I(objects[i].box.low, divide_axis) * (1 - SMALL); - cur_n1 = cur_n2 = 0; - for (j = 0; j < nobjects; ++j) { - double low = VEC_I(objects[j].box.low, divide_axis); - double high = VEC_I(objects[j].box.high, divide_axis); - cur_n1 += low <= cur_partition; - cur_n2 += high >= cur_partition; - } - CHECK(cur_n1 + cur_n2 >= nobjects, "assertion failure 2 in find_best_partition"); - if (MAX(cur_n1, cur_n2) < MAX(*n1, *n2)) { - *best_partition = cur_partition; - *n1 = cur_n1; - *n2 = cur_n2; - } - } +static void find_best_partition(int nobjects, const geom_box_object *objects, int divide_axis, + number *best_partition, int *n1, int *n2) { + number cur_partition; + int i, j, cur_n1, cur_n2; + + *n1 = *n2 = nobjects + 1; + *best_partition = 0; + + /* Search for the best partition, by checking all possible partitions + either just above the high end of an object or just below the + low end of an object. */ + + for (i = 0; i < nobjects; ++i) { + cur_partition = VEC_I(objects[i].box.high, divide_axis) * (1 + SMALL); + cur_n1 = cur_n2 = 0; + for (j = 0; j < nobjects; ++j) { + double low = VEC_I(objects[j].box.low, divide_axis); + double high = VEC_I(objects[j].box.high, divide_axis); + cur_n1 += low <= cur_partition; + cur_n2 += high >= cur_partition; + } + CHECK(cur_n1 + cur_n2 >= nobjects, "assertion failure 1 in find_best_partition"); + if (MAX(cur_n1, cur_n2) < MAX(*n1, *n2)) { + *best_partition = cur_partition; + *n1 = cur_n1; + *n2 = cur_n2; + } + } + for (i = 0; i < nobjects; ++i) { + cur_partition = VEC_I(objects[i].box.low, divide_axis) * (1 - SMALL); + cur_n1 = cur_n2 = 0; + for (j = 0; j < nobjects; ++j) { + double low = VEC_I(objects[j].box.low, divide_axis); + double high = VEC_I(objects[j].box.high, divide_axis); + cur_n1 += low <= cur_partition; + cur_n2 += high >= cur_partition; + } + CHECK(cur_n1 + cur_n2 >= nobjects, "assertion failure 2 in find_best_partition"); + if (MAX(cur_n1, cur_n2) < MAX(*n1, *n2)) { + *best_partition = cur_partition; + *n1 = cur_n1; + *n2 = cur_n2; + } + } } /* divide_geom_box_tree: recursively divide t in two, each time dividing along the axis that maximally partitions the boxes, and only stop partitioning when partitioning doesn't help any more. Upon return, t points to the partitioned tree. */ -static void divide_geom_box_tree(geom_box_tree t) -{ - int division_nobjects[3][2] = {{0,0},{0,0},{0,0}}; - number division_point[3]; - int best = -1; - int i, j, n1, n2; - - if (!t) - return; - if (t->t1 || t->t2) { /* this node has already been divided */ - divide_geom_box_tree(t->t1); - divide_geom_box_tree(t->t2); - return; - } - - if (t->nobjects <= 2) - return; /* no point in partitioning */ - - /* Try partitioning along each dimension, counting the - number of objects in the partitioned boxes and finding - the best partition. */ - for (i = 0; i < dimensions; ++i) { - if (VEC_I(t->b.high, i) == VEC_I(t->b.low, i)) continue; /* skip empty dimensions */ - find_best_partition(t->nobjects, t->objects, i, &division_point[i], - &division_nobjects[i][0], - &division_nobjects[i][1]); - if (best < 0 || - MAX(division_nobjects[i][0], division_nobjects[i][1]) < - MAX(division_nobjects[best][0], division_nobjects[best][1])) - best = i; - } - - /* don't do anything if division makes the worst case worse or if - it fails to improve the best case: */ - if (best < 0 || - MAX(division_nobjects[best][0], division_nobjects[best][1]) + 1 > t->nobjects || - MIN(division_nobjects[best][0], division_nobjects[best][1]) + 1 >= t->nobjects) - return; /* division didn't help us */ - - divide_geom_box(&t->b, best, division_point[best], &t->b1, &t->b2); - t->t1 = new_geom_box_tree(); - t->t2 = new_geom_box_tree(); - t->t1->b = t->b1; - t->t2->b = t->b2; - - t->t1->nobjects = division_nobjects[best][0]; - t->t1->objects = MALLOC(geom_box_object, t->t1->nobjects); - CHECK(t->t1->objects, "out of memory"); - - t->t2->nobjects = division_nobjects[best][1]; - t->t2->objects = MALLOC(geom_box_object, t->t2->nobjects); - CHECK(t->t2->objects, "out of memory"); - - for (j = n1 = n2 = 0; j < t->nobjects; ++j) { - if (geom_boxes_intersect(&t->b1, &t->objects[j].box)) { - CHECK(n1 < t->t1->nobjects, "BUG in divide_geom_box_tree"); - t->t1->objects[n1++] = t->objects[j]; - } - if (geom_boxes_intersect(&t->b2, &t->objects[j].box)) { - CHECK(n2 < t->t2->nobjects, "BUG in divide_geom_box_tree"); - t->t2->objects[n2++] = t->objects[j]; - } - } - CHECK(j == t->nobjects && n1 == t->t1->nobjects && n2 == t->t2->nobjects, - "BUG in divide_geom_box_tree: wrong nobjects"); - - t->nobjects = 0; - FREE(t->objects); - t->objects = NULL; - - divide_geom_box_tree(t->t1); - divide_geom_box_tree(t->t2); -} - -geom_box_tree create_geom_box_tree(void) -{ - geom_box b0; - b0.low = vector3_plus(geometry_center, - vector3_scale(-0.5, geometry_lattice.size)); - b0.high = vector3_plus(geometry_center, - vector3_scale(0.5, geometry_lattice.size)); - return create_geom_box_tree0(geometry, b0); -} - -static int num_objects_in_box(const geometric_object *o, vector3 shiftby, - const geom_box *b) -{ - if (o->which_subclass == GEOM COMPOUND_GEOMETRIC_OBJECT) { - int n = o->subclass.compound_geometric_object_data - ->component_objects.num_items; - geometric_object *os = o->subclass.compound_geometric_object_data - ->component_objects.items; - int i, sum = 0; - shiftby = vector3_plus(shiftby, o->center); - for (i = 0; i < n; ++i) - sum += num_objects_in_box(os + i, shiftby, b); - return sum; - } - else { - geom_box ob; - return object_in_box(*o, shiftby, &ob, b); - } -} - -static int store_objects_in_box(const geometric_object *o, vector3 shiftby, - const geom_box *b, - geom_box_object *bo, - int precedence) -{ - if (o->which_subclass == GEOM COMPOUND_GEOMETRIC_OBJECT) { - int n = o->subclass.compound_geometric_object_data - ->component_objects.num_items; - geometric_object *os = o->subclass.compound_geometric_object_data - ->component_objects.items; - int i, sum = 0; - shiftby = vector3_plus(shiftby, o->center); - for (i = 0; i < n; ++i) - sum += store_objects_in_box(os + i, shiftby, b, bo + sum, - precedence - sum); - return sum; - } - else { - geom_box ob; - if (object_in_box(*o, shiftby, &ob, b)) { - bo->box = ob; - bo->o = o; - bo->shiftby = shiftby; - bo->precedence = precedence; - return 1; - } - else - return 0; - } -} - -geom_box_tree create_geom_box_tree0(geometric_object_list geometry, - geom_box b0) -{ - geom_box_tree t = new_geom_box_tree(); - int i, index; - - t->b = b0; - - for (i = geometry.num_items - 1; i >= 0; --i) { - vector3 shiftby = {0,0,0}; - if (ensure_periodicity) { - LOOP_PERIODIC(shiftby, - t->nobjects += num_objects_in_box( - geometry.items + i, shiftby, &t->b)); - } - else - t->nobjects += num_objects_in_box( - geometry.items + i, shiftby, &t->b); - } - - t->objects = MALLOC(geom_box_object, t->nobjects); - CHECK(t->objects || t->nobjects == 0, "out of memory"); - - for (i = geometry.num_items - 1, index = 0; i >= 0; --i) { - vector3 shiftby = {0,0,0}; - if (ensure_periodicity) { - int precedence = t->nobjects - index; - LOOP_PERIODIC(shiftby, - index += store_objects_in_box( - geometry.items + i, shiftby, &t->b, - t->objects + index, precedence)); - } - else - index += store_objects_in_box( - geometry.items + i, shiftby, &t->b, - t->objects + index, t->nobjects - index); - } - CHECK(index == t->nobjects, "bug in create_geom_box_tree0"); +static void divide_geom_box_tree(geom_box_tree t) { + int division_nobjects[3][2] = {{0, 0}, {0, 0}, {0, 0}}; + number division_point[3]; + int best = -1; + int i, j, n1, n2; + + if (!t) return; + if (t->t1 || t->t2) { /* this node has already been divided */ + divide_geom_box_tree(t->t1); + divide_geom_box_tree(t->t2); + return; + } + + if (t->nobjects <= 2) return; /* no point in partitioning */ + + /* Try partitioning along each dimension, counting the + number of objects in the partitioned boxes and finding + the best partition. */ + for (i = 0; i < dimensions; ++i) { + if (VEC_I(t->b.high, i) == VEC_I(t->b.low, i)) continue; /* skip empty dimensions */ + find_best_partition(t->nobjects, t->objects, i, &division_point[i], &division_nobjects[i][0], + &division_nobjects[i][1]); + if (best < 0 || MAX(division_nobjects[i][0], division_nobjects[i][1]) < + MAX(division_nobjects[best][0], division_nobjects[best][1])) + best = i; + } + + /* don't do anything if division makes the worst case worse or if + it fails to improve the best case: */ + if (best < 0 || MAX(division_nobjects[best][0], division_nobjects[best][1]) + 1 > t->nobjects || + MIN(division_nobjects[best][0], division_nobjects[best][1]) + 1 >= t->nobjects) + return; /* division didn't help us */ + + divide_geom_box(&t->b, best, division_point[best], &t->b1, &t->b2); + t->t1 = new_geom_box_tree(); + t->t2 = new_geom_box_tree(); + t->t1->b = t->b1; + t->t2->b = t->b2; + + t->t1->nobjects = division_nobjects[best][0]; + t->t1->objects = MALLOC(geom_box_object, t->t1->nobjects); + CHECK(t->t1->objects, "out of memory"); + + t->t2->nobjects = division_nobjects[best][1]; + t->t2->objects = MALLOC(geom_box_object, t->t2->nobjects); + CHECK(t->t2->objects, "out of memory"); + + for (j = n1 = n2 = 0; j < t->nobjects; ++j) { + if (geom_boxes_intersect(&t->b1, &t->objects[j].box)) { + CHECK(n1 < t->t1->nobjects, "BUG in divide_geom_box_tree"); + t->t1->objects[n1++] = t->objects[j]; + } + if (geom_boxes_intersect(&t->b2, &t->objects[j].box)) { + CHECK(n2 < t->t2->nobjects, "BUG in divide_geom_box_tree"); + t->t2->objects[n2++] = t->objects[j]; + } + } + CHECK(j == t->nobjects && n1 == t->t1->nobjects && n2 == t->t2->nobjects, + "BUG in divide_geom_box_tree: wrong nobjects"); - divide_geom_box_tree(t); + t->nobjects = 0; + FREE(t->objects); + t->objects = NULL; + + divide_geom_box_tree(t->t1); + divide_geom_box_tree(t->t2); +} + +geom_box_tree create_geom_box_tree(void) { + geom_box b0; + b0.low = vector3_plus(geometry_center, vector3_scale(-0.5, geometry_lattice.size)); + b0.high = vector3_plus(geometry_center, vector3_scale(0.5, geometry_lattice.size)); + return create_geom_box_tree0(geometry, b0); +} + +static int num_objects_in_box(const geometric_object *o, vector3 shiftby, const geom_box *b) { + if (o->which_subclass == GEOM COMPOUND_GEOMETRIC_OBJECT) { + int n = o->subclass.compound_geometric_object_data->component_objects.num_items; + geometric_object *os = o->subclass.compound_geometric_object_data->component_objects.items; + int i, sum = 0; + shiftby = vector3_plus(shiftby, o->center); + for (i = 0; i < n; ++i) + sum += num_objects_in_box(os + i, shiftby, b); + return sum; + } + else { + geom_box ob; + return object_in_box(*o, shiftby, &ob, b); + } +} - return t; +static int store_objects_in_box(const geometric_object *o, vector3 shiftby, const geom_box *b, + geom_box_object *bo, int precedence) { + if (o->which_subclass == GEOM COMPOUND_GEOMETRIC_OBJECT) { + int n = o->subclass.compound_geometric_object_data->component_objects.num_items; + geometric_object *os = o->subclass.compound_geometric_object_data->component_objects.items; + int i, sum = 0; + shiftby = vector3_plus(shiftby, o->center); + for (i = 0; i < n; ++i) + sum += store_objects_in_box(os + i, shiftby, b, bo + sum, precedence - sum); + return sum; + } + else { + geom_box ob; + if (object_in_box(*o, shiftby, &ob, b)) { + bo->box = ob; + bo->o = o; + bo->shiftby = shiftby; + bo->precedence = precedence; + return 1; + } + else + return 0; + } +} + +geom_box_tree create_geom_box_tree0(geometric_object_list geometry, geom_box b0) { + geom_box_tree t = new_geom_box_tree(); + int i, index; + + t->b = b0; + + for (i = geometry.num_items - 1; i >= 0; --i) { + vector3 shiftby = {0, 0, 0}; + if (ensure_periodicity) { + LOOP_PERIODIC(shiftby, t->nobjects += num_objects_in_box(geometry.items + i, shiftby, &t->b)); + } + else + t->nobjects += num_objects_in_box(geometry.items + i, shiftby, &t->b); + } + + t->objects = MALLOC(geom_box_object, t->nobjects); + CHECK(t->objects || t->nobjects == 0, "out of memory"); + + for (i = geometry.num_items - 1, index = 0; i >= 0; --i) { + vector3 shiftby = {0, 0, 0}; + if (ensure_periodicity) { + int precedence = t->nobjects - index; + LOOP_PERIODIC(shiftby, index += store_objects_in_box(geometry.items + i, shiftby, &t->b, + t->objects + index, precedence)); + } + else + index += store_objects_in_box(geometry.items + i, shiftby, &t->b, t->objects + index, + t->nobjects - index); + } + CHECK(index == t->nobjects, "bug in create_geom_box_tree0"); + + divide_geom_box_tree(t); + + return t; } /* create a new tree from t, pruning all nodes that don't intersect b */ -geom_box_tree restrict_geom_box_tree(geom_box_tree t, const geom_box *b) -{ - geom_box_tree tr; - int i, j; - - if (!t || !geom_boxes_intersect(&t->b, b)) - return NULL; - - tr = new_geom_box_tree(); - - for (i = 0, j = 0; i < t->nobjects; ++i) - if (geom_boxes_intersect(&t->objects[i].box, b)) - ++j; - tr->nobjects = j; - tr->objects = MALLOC(geom_box_object, tr->nobjects); - CHECK(tr->objects || tr->nobjects == 0, "out of memory"); - - for (i = 0, j = 0; i < t->nobjects; ++i) - if (geom_boxes_intersect(&t->objects[i].box, b)) - tr->objects[j++] = t->objects[i]; - - tr->t1 = restrict_geom_box_tree(t->t1, b); - tr->t2 = restrict_geom_box_tree(t->t2, b); - - if (tr->nobjects == 0) { - if (tr->t1 && !tr->t2) { - geom_box_tree tr0 = tr; - tr = tr->t1; - FREE1(tr0); - } - else if (tr->t2 && !tr->t1) { - geom_box_tree tr0 = tr; - tr = tr->t2; - FREE1(tr0); - } - } +geom_box_tree restrict_geom_box_tree(geom_box_tree t, const geom_box *b) { + geom_box_tree tr; + int i, j; + + if (!t || !geom_boxes_intersect(&t->b, b)) return NULL; + + tr = new_geom_box_tree(); + + for (i = 0, j = 0; i < t->nobjects; ++i) + if (geom_boxes_intersect(&t->objects[i].box, b)) ++j; + tr->nobjects = j; + tr->objects = MALLOC(geom_box_object, tr->nobjects); + CHECK(tr->objects || tr->nobjects == 0, "out of memory"); + + for (i = 0, j = 0; i < t->nobjects; ++i) + if (geom_boxes_intersect(&t->objects[i].box, b)) tr->objects[j++] = t->objects[i]; + + tr->t1 = restrict_geom_box_tree(t->t1, b); + tr->t2 = restrict_geom_box_tree(t->t2, b); + + if (tr->nobjects == 0) { + if (tr->t1 && !tr->t2) { + geom_box_tree tr0 = tr; + tr = tr->t1; + FREE1(tr0); + } + else if (tr->t2 && !tr->t1) { + geom_box_tree tr0 = tr; + tr = tr->t2; + FREE1(tr0); + } + } - return tr; + return tr; } /**************************************************************************/ @@ -1879,141 +1648,120 @@ subtree (if any) that contains it and the index oindex of the object in that tree. The input value of oindex indicates the starting object to search in t (0 to search all). */ -static geom_box_tree tree_search(vector3 p, geom_box_tree t, int *oindex) -{ - int i; - geom_box_tree gbt; - - if (!t || !geom_box_contains_point(&t->b, p)) - return NULL; - - for (i = *oindex; i < t->nobjects; ++i) - if (geom_box_contains_point(&t->objects[i].box, p) && - point_in_fixed_objectp(vector3_minus(p, t->objects[i].shiftby), - *t->objects[i].o)) { - *oindex = i; - return t; - } - - *oindex = 0; - gbt = tree_search(p, t->t1, oindex); - if (!gbt) - gbt = tree_search(p, t->t2, oindex); - return gbt; +static geom_box_tree tree_search(vector3 p, geom_box_tree t, int *oindex) { + int i; + geom_box_tree gbt; + + if (!t || !geom_box_contains_point(&t->b, p)) return NULL; + + for (i = *oindex; i < t->nobjects; ++i) + if (geom_box_contains_point(&t->objects[i].box, p) && + point_in_fixed_objectp(vector3_minus(p, t->objects[i].shiftby), *t->objects[i].o)) { + *oindex = i; + return t; + } + + *oindex = 0; + gbt = tree_search(p, t->t1, oindex); + if (!gbt) gbt = tree_search(p, t->t2, oindex); + return gbt; } /* shift p to be within the unit cell of the lattice (centered on the origin) */ -vector3 shift_to_unit_cell(vector3 p) -{ - while (p.x >= 0.5 * geometry_lattice.size.x) - p.x -= geometry_lattice.size.x; - while (p.x < -0.5 * geometry_lattice.size.x) - p.x += geometry_lattice.size.x; - while (p.y >= 0.5 * geometry_lattice.size.y) - p.y -= geometry_lattice.size.y; - while (p.y < -0.5 * geometry_lattice.size.y) - p.y += geometry_lattice.size.y; - while (p.z >= 0.5 * geometry_lattice.size.z) - p.z -= geometry_lattice.size.z; - while (p.z < -0.5 * geometry_lattice.size.z) - p.z += geometry_lattice.size.z; - return p; -} - -const geometric_object *object_of_point_in_tree(vector3 p, geom_box_tree t, - vector3 *shiftby, - int *precedence) -{ - int oindex = 0; - t = tree_search(p, t, &oindex); - if (t) { - geom_box_object *gbo = t->objects + oindex; - *shiftby = gbo->shiftby; - *precedence = gbo->precedence; - return gbo->o; - } - else { - shiftby->x = shiftby->y = shiftby->z = 0; - *precedence = 0; - return 0; - } -} - -material_type material_of_unshifted_point_in_tree_inobject( - vector3 p, geom_box_tree t, boolean *inobject) -{ - int oindex = 0; - t = tree_search(p, t, &oindex); - if (t) { - *inobject = 1; - return (t->objects[oindex].o->material); - } - else { - *inobject = 0; - return default_material; - } -} - -material_type material_of_point_in_tree_inobject(vector3 p, geom_box_tree t, - boolean *inobject) -{ - /* backwards compatibility */ - return material_of_unshifted_point_in_tree_inobject( - shift_to_unit_cell(p), t, inobject); -} - -material_type material_of_point_in_tree(vector3 p, geom_box_tree t) -{ - boolean inobject; - return material_of_point_in_tree_inobject(p, t, &inobject); -} - -geom_box_tree geom_tree_search_next(vector3 p, geom_box_tree t, int *oindex) -{ - *oindex += 1; /* search starting at next oindex */ - return tree_search(p, t, oindex); -} - -geom_box_tree geom_tree_search(vector3 p, geom_box_tree t, int *oindex) -{ - *oindex = -1; /* search all indices > -1 */ - return geom_tree_search_next(p, t, oindex); +vector3 shift_to_unit_cell(vector3 p) { + while (p.x >= 0.5 * geometry_lattice.size.x) + p.x -= geometry_lattice.size.x; + while (p.x < -0.5 * geometry_lattice.size.x) + p.x += geometry_lattice.size.x; + while (p.y >= 0.5 * geometry_lattice.size.y) + p.y -= geometry_lattice.size.y; + while (p.y < -0.5 * geometry_lattice.size.y) + p.y += geometry_lattice.size.y; + while (p.z >= 0.5 * geometry_lattice.size.z) + p.z -= geometry_lattice.size.z; + while (p.z < -0.5 * geometry_lattice.size.z) + p.z += geometry_lattice.size.z; + return p; +} + +const geometric_object *object_of_point_in_tree(vector3 p, geom_box_tree t, vector3 *shiftby, + int *precedence) { + int oindex = 0; + t = tree_search(p, t, &oindex); + if (t) { + geom_box_object *gbo = t->objects + oindex; + *shiftby = gbo->shiftby; + *precedence = gbo->precedence; + return gbo->o; + } + else { + shiftby->x = shiftby->y = shiftby->z = 0; + *precedence = 0; + return 0; + } +} + +material_type material_of_unshifted_point_in_tree_inobject(vector3 p, geom_box_tree t, + boolean *inobject) { + int oindex = 0; + t = tree_search(p, t, &oindex); + if (t) { + *inobject = 1; + return (t->objects[oindex].o->material); + } + else { + *inobject = 0; + return default_material; + } +} + +material_type material_of_point_in_tree_inobject(vector3 p, geom_box_tree t, boolean *inobject) { + /* backwards compatibility */ + return material_of_unshifted_point_in_tree_inobject(shift_to_unit_cell(p), t, inobject); +} + +material_type material_of_point_in_tree(vector3 p, geom_box_tree t) { + boolean inobject; + return material_of_point_in_tree_inobject(p, t, &inobject); +} + +geom_box_tree geom_tree_search_next(vector3 p, geom_box_tree t, int *oindex) { + *oindex += 1; /* search starting at next oindex */ + return tree_search(p, t, oindex); +} + +geom_box_tree geom_tree_search(vector3 p, geom_box_tree t, int *oindex) { + *oindex = -1; /* search all indices > -1 */ + return geom_tree_search_next(p, t, oindex); } /**************************************************************************/ /* convert a vector p in the given object to some coordinate in [0,1]^3 that is a more "natural" map of the object interior. */ -vector3 to_geom_box_coords(vector3 p, geom_box_object *gbo) -{ - return to_geom_object_coords(vector3_minus(p, gbo->shiftby), *gbo->o); +vector3 to_geom_box_coords(vector3 p, geom_box_object *gbo) { + return to_geom_object_coords(vector3_minus(p, gbo->shiftby), *gbo->o); } /**************************************************************************/ -void display_geom_box_tree(int indentby, geom_box_tree t) -{ - int i; - - if (!t) - return; - ctl_printf("%*sbox (%g..%g, %g..%g, %g..%g)\n", indentby, "", - t->b.low.x, t->b.high.x, - t->b.low.y, t->b.high.y, - t->b.low.z, t->b.high.z); - for (i = 0; i < t->nobjects; ++i) { - ctl_printf("%*sbounding box (%g..%g, %g..%g, %g..%g)\n", indentby+5, "", - t->objects[i].box.low.x, t->objects[i].box.high.x, - t->objects[i].box.low.y, t->objects[i].box.high.y, - t->objects[i].box.low.z, t->objects[i].box.high.z); - ctl_printf("%*sshift object by (%g, %g, %g)\n", indentby+5, "", - t->objects[i].shiftby.x, t->objects[i].shiftby.y, - t->objects[i].shiftby.z); - display_geometric_object_info(indentby + 5, *t->objects[i].o); - } - display_geom_box_tree(indentby + 5, t->t1); - display_geom_box_tree(indentby + 5, t->t2); +void display_geom_box_tree(int indentby, geom_box_tree t) { + int i; + + if (!t) return; + ctl_printf("%*sbox (%g..%g, %g..%g, %g..%g)\n", indentby, "", t->b.low.x, t->b.high.x, t->b.low.y, + t->b.high.y, t->b.low.z, t->b.high.z); + for (i = 0; i < t->nobjects; ++i) { + ctl_printf("%*sbounding box (%g..%g, %g..%g, %g..%g)\n", indentby + 5, "", + t->objects[i].box.low.x, t->objects[i].box.high.x, t->objects[i].box.low.y, + t->objects[i].box.high.y, t->objects[i].box.low.z, t->objects[i].box.high.z); + ctl_printf("%*sshift object by (%g, %g, %g)\n", indentby + 5, "", t->objects[i].shiftby.x, + t->objects[i].shiftby.y, t->objects[i].shiftby.z); + display_geometric_object_info(indentby + 5, *t->objects[i].o); + } + display_geom_box_tree(indentby + 5, t->t1); + display_geom_box_tree(indentby + 5, t->t2); } /**************************************************************************/ @@ -2021,46 +1769,41 @@ /* Computing tree statistics (depth and number of nodes): */ /* helper function for geom_box_tree_stats */ -static void get_tree_stats(geom_box_tree t, int *depth, int *nobjects) -{ - if (t) { - int d1, d2; - - *nobjects += t->nobjects; - d1 = d2 = *depth + 1; - get_tree_stats(t->t1, &d1, nobjects); - get_tree_stats(t->t2, &d2, nobjects); - *depth = MAX(d1, d2); - } -} - -void geom_box_tree_stats(geom_box_tree t, int *depth, int *nobjects) -{ - *depth = *nobjects = 0; - get_tree_stats(t, depth, nobjects); +static void get_tree_stats(geom_box_tree t, int *depth, int *nobjects) { + if (t) { + int d1, d2; + + *nobjects += t->nobjects; + d1 = d2 = *depth + 1; + get_tree_stats(t->t1, &d1, nobjects); + get_tree_stats(t->t2, &d2, nobjects); + *depth = MAX(d1, d2); + } +} + +void geom_box_tree_stats(geom_box_tree t, int *depth, int *nobjects) { + *depth = *nobjects = 0; + get_tree_stats(t, depth, nobjects); } /**************************************************************************/ #ifndef LIBCTLGEOM -vector3 get_grid_size(void) -{ - return ctl_convert_vector3_to_c(gh_call0(gh_lookup("get-grid-size"))); -} - -vector3 get_resolution(void) -{ - return ctl_convert_vector3_to_c(gh_call0(gh_lookup("get-resolution"))); -} - -void get_grid_size_n(int *nx, int *ny, int *nz) -{ - vector3 grid_size; - grid_size = get_grid_size(); - *nx = (int) grid_size.x; - *ny = (int) grid_size.y; - *nz = (int) grid_size.z; +vector3 get_grid_size(void) { + return ctl_convert_vector3_to_c(gh_call0(gh_lookup("get-grid-size"))); +} + +vector3 get_resolution(void) { + return ctl_convert_vector3_to_c(gh_call0(gh_lookup("get-resolution"))); +} + +void get_grid_size_n(int *nx, int *ny, int *nz) { + vector3 grid_size; + grid_size = get_grid_size(); + *nx = (int)grid_size.x; + *ny = (int)grid_size.y; + *nz = (int)grid_size.z; } #endif @@ -2070,106 +1813,93 @@ /* constructors for the geometry types (ugh, wish these could be automatically generated from geom.scm) */ -geometric_object make_geometric_object(material_type material, vector3 center) -{ - geometric_object o; - material_type_copy(&material, &o.material); - o.center = center; - o.which_subclass = GEOM GEOMETRIC_OBJECT_SELF; - return o; -} - -geometric_object make_cylinder(material_type material, vector3 center, - number radius, number height, vector3 axis) -{ - geometric_object o = make_geometric_object(material, center); - o.which_subclass = GEOM CYLINDER; - o.subclass.cylinder_data = MALLOC1(cylinder); - CHECK(o.subclass.cylinder_data, "out of memory"); - o.subclass.cylinder_data->radius = radius; - o.subclass.cylinder_data->height = height; - o.subclass.cylinder_data->axis = axis; - o.subclass.cylinder_data->which_subclass = CYL CYLINDER_SELF; - geom_fix_object_ptr(&o); - return o; -} - -geometric_object make_cone(material_type material, vector3 center, - number radius, number height, vector3 axis, - number radius2) -{ - geometric_object o = make_cylinder(material, center, radius,height, axis); - o.subclass.cylinder_data->which_subclass = CYL CONE; - o.subclass.cylinder_data->subclass.cone_data = MALLOC1(cone); - CHECK(o.subclass.cylinder_data->subclass.cone_data, "out of memory"); - o.subclass.cylinder_data->subclass.cone_data->radius2 = radius2; - return o; -} - -geometric_object make_wedge(material_type material, vector3 center, - number radius, number height, vector3 axis, - number wedge_angle, vector3 wedge_start) -{ - geometric_object o = make_cylinder(material, center, radius,height, axis); - o.subclass.cylinder_data->which_subclass = CYL WEDGE; - o.subclass.cylinder_data->subclass.wedge_data = MALLOC1(wedge); - CHECK(o.subclass.cylinder_data->subclass.wedge_data, "out of memory"); - o.subclass.cylinder_data->subclass.wedge_data->wedge_angle = wedge_angle; - o.subclass.cylinder_data->subclass.wedge_data->wedge_start = wedge_start; - geom_fix_object_ptr(&o); - return o; -} - -geometric_object make_sphere(material_type material, vector3 center, - number radius) -{ - geometric_object o = make_geometric_object(material, center); - o.which_subclass = GEOM SPHERE; - o.subclass.sphere_data = MALLOC1(sphere); - CHECK(o.subclass.sphere_data, "out of memory"); - o.subclass.sphere_data->radius = radius; - return o; -} - -geometric_object make_block(material_type material, vector3 center, - vector3 e1, vector3 e2, vector3 e3, - vector3 size) -{ - geometric_object o = make_geometric_object(material, center); - o.which_subclass = GEOM BLOCK; - o.subclass.block_data = MALLOC1(block); - CHECK(o.subclass.block_data, "out of memory"); - o.subclass.block_data->e1 = e1; - o.subclass.block_data->e2 = e2; - o.subclass.block_data->e3 = e3; - o.subclass.block_data->size = size; - o.subclass.block_data->which_subclass = BLK BLOCK_SELF; - geom_fix_object_ptr(&o); - return o; -} - -geometric_object make_ellipsoid(material_type material, vector3 center, - vector3 e1, vector3 e2, vector3 e3, - vector3 size) -{ - geometric_object o = make_block(material, center, e1,e2,e3, size); - o.subclass.block_data->which_subclass = BLK ELLIPSOID; - o.subclass.block_data->subclass.ellipsoid_data = MALLOC1(ellipsoid); - CHECK(o.subclass.block_data->subclass.ellipsoid_data, "out of memory"); - o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes.x - = 2.0 / size.x; - o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes.y - = 2.0 / size.y; - o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes.z - = 2.0 / size.z; - return o; +geometric_object make_geometric_object(material_type material, vector3 center) { + geometric_object o; + material_type_copy(&material, &o.material); + o.center = center; + o.which_subclass = GEOM GEOMETRIC_OBJECT_SELF; + return o; +} + +geometric_object make_cylinder(material_type material, vector3 center, number radius, number height, + vector3 axis) { + geometric_object o = make_geometric_object(material, center); + o.which_subclass = GEOM CYLINDER; + o.subclass.cylinder_data = MALLOC1(cylinder); + CHECK(o.subclass.cylinder_data, "out of memory"); + o.subclass.cylinder_data->radius = radius; + o.subclass.cylinder_data->height = height; + o.subclass.cylinder_data->axis = axis; + o.subclass.cylinder_data->which_subclass = CYL CYLINDER_SELF; + geom_fix_object_ptr(&o); + return o; +} + +geometric_object make_cone(material_type material, vector3 center, number radius, number height, + vector3 axis, number radius2) { + geometric_object o = make_cylinder(material, center, radius, height, axis); + o.subclass.cylinder_data->which_subclass = CYL CONE; + o.subclass.cylinder_data->subclass.cone_data = MALLOC1(cone); + CHECK(o.subclass.cylinder_data->subclass.cone_data, "out of memory"); + o.subclass.cylinder_data->subclass.cone_data->radius2 = radius2; + return o; +} + +geometric_object make_wedge(material_type material, vector3 center, number radius, number height, + vector3 axis, number wedge_angle, vector3 wedge_start) { + geometric_object o = make_cylinder(material, center, radius, height, axis); + o.subclass.cylinder_data->which_subclass = CYL WEDGE; + o.subclass.cylinder_data->subclass.wedge_data = MALLOC1(wedge); + CHECK(o.subclass.cylinder_data->subclass.wedge_data, "out of memory"); + o.subclass.cylinder_data->subclass.wedge_data->wedge_angle = wedge_angle; + o.subclass.cylinder_data->subclass.wedge_data->wedge_start = wedge_start; + geom_fix_object_ptr(&o); + return o; +} + +geometric_object make_sphere(material_type material, vector3 center, number radius) { + geometric_object o = make_geometric_object(material, center); + o.which_subclass = GEOM SPHERE; + o.subclass.sphere_data = MALLOC1(sphere); + CHECK(o.subclass.sphere_data, "out of memory"); + o.subclass.sphere_data->radius = radius; + return o; +} + +geometric_object make_block(material_type material, vector3 center, vector3 e1, vector3 e2, + vector3 e3, vector3 size) { + geometric_object o = make_geometric_object(material, center); + o.which_subclass = GEOM BLOCK; + o.subclass.block_data = MALLOC1(block); + CHECK(o.subclass.block_data, "out of memory"); + o.subclass.block_data->e1 = e1; + o.subclass.block_data->e2 = e2; + o.subclass.block_data->e3 = e3; + o.subclass.block_data->size = size; + o.subclass.block_data->which_subclass = BLK BLOCK_SELF; + geom_fix_object_ptr(&o); + return o; +} + +geometric_object make_ellipsoid(material_type material, vector3 center, vector3 e1, vector3 e2, + vector3 e3, vector3 size) { + geometric_object o = make_block(material, center, e1, e2, e3, size); + o.subclass.block_data->which_subclass = BLK ELLIPSOID; + o.subclass.block_data->subclass.ellipsoid_data = MALLOC1(ellipsoid); + CHECK(o.subclass.block_data->subclass.ellipsoid_data, "out of memory"); + o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes.x = 2.0 / size.x; + o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes.y = 2.0 / size.y; + o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes.z = 2.0 / size.z; + return o; } /*************************************************************** * The remainder of this file implements geometric primitives for prisms. * A prism is a planar polygon, consisting of 3 or more user-specified - * vertices, extruded through a given thickness (the "height") in the - * direction of a given unit vector (the "axis.") + * vertices (the "bottom_vertices), extruded through a given thickness + * (the "height") in the direction of a given unit vector (the "axis") + * with the walls of the extrusion tapering at a given angle angle + * (the "sidewall_angle). * Most calculations are done in the "prism coordinate system", * in which the prism floor lies in the XY plane with centroid * at the origin and the prism axis is the positive Z-axis. @@ -2191,17 +1921,21 @@ /* given coordinates of a point in the prism coordinate system,*/ /* return cartesian coordinates of that point */ /***************************************************************/ -vector3 prism_coordinate_p2c(prism *prsm, vector3 pp) -{ return vector3_plus(prsm->centroid, matrix3x3_vector3_mult(prsm->m_p2c,pp)); } +vector3 prism_coordinate_p2c(prism *prsm, vector3 pp) { + return vector3_plus(prsm->centroid, matrix3x3_vector3_mult(prsm->m_p2c, pp)); +} -vector3 prism_vector_p2c(prism *prsm, vector3 vp) -{ return matrix3x3_vector3_mult(prsm->m_p2c, vp); } +vector3 prism_vector_p2c(prism *prsm, vector3 vp) { + return matrix3x3_vector3_mult(prsm->m_p2c, vp); +} -vector3 prism_coordinate_c2p(prism *prsm, vector3 pc) -{ return matrix3x3_vector3_mult(prsm->m_c2p, vector3_minus(pc,prsm->centroid)); } +vector3 prism_coordinate_c2p(prism *prsm, vector3 pc) { + return matrix3x3_vector3_mult(prsm->m_c2p, vector3_minus(pc, prsm->centroid)); +} -vector3 prism_vector_c2p(prism *prsm, vector3 vc) -{ return matrix3x3_vector3_mult(prsm->m_c2p, vc); } +vector3 prism_vector_c2p(prism *prsm, vector3 vc) { + return matrix3x3_vector3_mult(prsm->m_c2p, vc); +} /***************************************************************/ /* given 2D points q0,q1,q2 and a 2D vector u, determine */ @@ -2223,131 +1957,185 @@ /***************************************************************/ #define THRESH 1.0e-5 #define NON_INTERSECTING 0 -#define INTERSECTING 1 -#define IN_SEGMENT 2 -#define ON_RAY 3 -int intersect_line_with_segment(vector3 q0, vector3 q1, vector3 q2, vector3 u, double *s) -{ +#define INTERSECTING 1 +#define IN_SEGMENT 2 +#define ON_RAY 3 +int intersect_line_with_segment(vector3 q0, vector3 q1, vector3 q2, vector3 u, double *s) { /* ||ux q1x-q2x|| |s| = | q1x-q0x | */ /* ||uy q1y-q2y|| |t| = | q1y-q0y | */ - double M00 = u.x, M01=q1.x-q2.x; - double M10 = u.y, M11=q1.y-q2.y; - double RHSx = q1.x-q0.x; - double RHSy = q1.y-q0.y; - double DetM = M00*M11 - M01*M10; - double L2 = M01*M01 + M11*M11; // squared length of edge, used to set length scale - if ( fabs(DetM) < 1.0e-10*L2 ) - { // d zero or nearly parallel to edge - double q01x = q0.x-q1.x, q01y = q0.y-q1.y, q01 = sqrt(q01x*q01x+q01y*q01y); - double q02x = q0.x-q2.x, q02y = q0.y-q2.y, q02 = sqrt(q02x*q02x+q02y*q02y); - double dot = q01x*q02x + q01y*q02y; - if ( fabs(dot) < (1.0-THRESH)*q01*q02 ) + double M00 = u.x, M01 = q1.x - q2.x; + double M10 = u.y, M11 = q1.y - q2.y; + double RHSx = q1.x - q0.x; + double RHSy = q1.y - q0.y; + double DetM = M00 * M11 - M01 * M10; + double L2 = M01 * M01 + M11 * M11; // squared length of edge, used to set length scale + if (fabs(DetM) < 1.0e-10 * L2) { // d zero or nearly parallel to edge + if (vector3_nearly_equal(q0, q1, 1e-12) || vector3_nearly_equal(q0, q2, 1e-12)) return IN_SEGMENT; + double q01x = q0.x - q1.x, q01y = q0.y - q1.y, q01 = sqrt(q01x * q01x + q01y * q01y); + double q02x = q0.x - q2.x, q02y = q0.y - q2.y, q02 = sqrt(q02x * q02x + q02y * q02y); + double dot = q01x * q02x + q01y * q02y; + if (fabs(dot) < (1.0 - THRESH) * q01 * q02) return NON_INTERSECTING; - else if (dot<0.0) - { *s=0.0; - return IN_SEGMENT; - } - else if ( (u.x*q01x + u.y*q01y) < 0.0 ) - { *s = fmin(q01, q02) / sqrt(u.x*u.x + u.y*u.y); - return ON_RAY; - } - return NON_INTERSECTING; - } + else if (dot < 0.0) { + *s = 0.0; + return IN_SEGMENT; + } + else if ((u.x * q01x + u.y * q01y) < 0.0) { + *s = fmin(q01, q02) / sqrt(u.x * u.x + u.y * u.y); + return ON_RAY; + } + return NON_INTERSECTING; + } - float t = (M00*RHSy-M10*RHSx)/DetM; - if (s) *s = (M11*RHSx-M01*RHSy)/DetM; + float t = (M00 * RHSy - M10 * RHSx) / DetM; + if (s) *s = (M11 * RHSx - M01 * RHSy) / DetM; // the plumb line intersects the segment if 0<=t<=1, with t==0,1 // corresponding to the endpoints; for our purposes we count // the intersection if the plumb line runs through the t==0 vertex, but // NOT the t==1 vertex, to avoid double-counting for complete polygons. - return ( t<-THRESH || t>=(1-THRESH) ) ? NON_INTERSECTING : INTERSECTING; + return (t < -THRESH || t >= (1 - THRESH)) ? NON_INTERSECTING : INTERSECTING; } // like the previous routine, but only count intersections if s>=0 -boolean intersect_ray_with_segment(vector3 q0, vector3 q1, vector3 q2, vector3 u, - double *s) -{ +boolean intersect_ray_with_segment(vector3 q0, vector3 q1, vector3 q2, vector3 u, double *s) { double ss; - int status=intersect_line_with_segment(q0,q1,q2,u,&ss); - if (status==INTERSECTING && ss<0.0) - return NON_INTERSECTING; - if (s) *s=ss; + int status = intersect_line_with_segment(q0, q1, q2, u, &ss); + if (status == INTERSECTING && ss < 0.0) return NON_INTERSECTING; + if (s) *s = ss; return status; } /***************************************************************/ /* 2D point-in-polygon test: return 1 if q0 lies within the */ /* polygon with the given vertices, 0 otherwise. */ -// method: cast a plumb line in the negative y direction from */ +// method: cast a plumb line in the positive x direction from */ /* q0 to infinity and count the number of edges intersected; */ /* point lies in polygon iff this is number is odd. */ /***************************************************************/ +/* Implementation of: */ +/* */ +/* M. Galetzka and P. Glauner, "A Simple and Correct Even-Odd */ +/* Algorithm for the Point-in-Polygon Problem for Complex */ +/* Polygons", Proceedings of the 12th International Joint */ +/* Conference on Computer Vision, Imaging and Computer */ +/* Graphics Theory and Applications (VISIGRAPP 2017), Volume */ +/* 1: GRAPP, Porto, Portugal, 2017. */ +/***************************************************************/ + boolean node_in_or_on_polygon(vector3 q0, vector3 *nodes, int num_nodes, - boolean include_boundaries) -{ - vector3 u = {0.0, -1.0, 0.0}; - int nn, edges_crossed=0; - for(nn=0; nn THRESH) { + startNodePosition = nn; + startPoint = nodes[startNodePosition]; + } + } + // No start point found and point is not on an edge or node + // --> point is outside + if (startNodePosition == -1) { return 0; } + + int checkedPoints = 0; + nn = startNodePosition; + + // Consider all edges + while (checkedPoints < num_nodes) { + int savedIndex = (nn + 1) % num_nodes; + double savedX = nodes[savedIndex].x; + + // Move to next point which is not on the x-axis + do { + nn = (nn + 1) % num_nodes; + checkedPoints++; + } while (fabs(nodes[nn].y - q0.y) < THRESH); + // Found end point + endPoint = nodes[nn]; + + // Only intersect lines that cross the x-axis (don't need to correct for rounding + // error in the if statement because startPoint and endPoint are screened to + // never lie on the x-axis) + if ((startPoint.y - q0.y) * (endPoint.y - q0.y) < 0) { + // No nodes have been skipped and the successor node + // has been chose as the end point + if (savedIndex == nn) { + int status = intersect_ray_with_segment(q0, startPoint, endPoint, xAxis, 0); + if (status == INTERSECTING) { edges_crossed++; } + } + // If at least one node on the right side has been skipped, + // the original edge would have been intersected + // --> intersect with full x-axis + else if (savedX > q0.x + THRESH) { + int status = intersect_line_with_segment(q0, startPoint, endPoint, xAxis, 0); + if (status == INTERSECTING) { edges_crossed++; } + } + } + // End point is the next start point + startPoint = endPoint; + } -boolean node_in_polygon(double q0x, double q0y, vector3 *nodes, int num_nodes) -{ vector3 q0; - q0.x=q0x; q0.y=q0y; q0.z=0.0; + // Odd count --> in the polygon (1) + // Even count --> outside (0) + return edges_crossed % 2; +} + +boolean node_in_polygon(double q0x, double q0y, vector3 *nodes, int num_nodes) { + vector3 q0; + q0.x = q0x; + q0.y = q0y; + q0.z = 0.0; return node_in_or_on_polygon(q0, nodes, num_nodes, 1); } /***************************************************************/ /* return 1 or 0 if pc lies inside or outside the prism */ /***************************************************************/ -boolean point_in_or_on_prism(prism *prsm, vector3 pc, boolean include_boundaries) -{ - double height = prsm->height; - vector3 pp = prism_coordinate_c2p(prsm, pc); - if ( pp.z<0.0 || pp.z>prsm->height ) - return 0; - vector3 *nodes = prsm->vertices_p.items; - int num_nodes = prsm->vertices_p.num_items; +boolean point_in_or_on_prism(prism *prsm, vector3 pc, boolean include_boundaries) { + double height = prsm->height; + vector3 pp = prism_coordinate_c2p(prsm, pc); + if (pp.z < 0.0 || pp.z > prsm->height) return 0; + int num_nodes = prsm->vertices_p.num_items; + vector3 nodes[num_nodes]; + int nv; + for (nv = 0; nv < num_nodes; nv++) { + nodes[nv] = vector3_plus(prsm->vertices_p.items[nv], vector3_scale(pp.z, prsm->top_polygon_diff_vectors_scaled_p.items[nv])); + } return node_in_or_on_polygon(pp, nodes, num_nodes, include_boundaries); } -boolean point_in_prism(prism *prsm, vector3 pc) -{ +boolean point_in_prism(prism *prsm, vector3 pc) { // by default, points on polygon edges are considered to lie inside the // polygon; this can be reversed by setting the environment variable // LIBCTL_EXCLUDE_BOUNDARIES=1 - static boolean include_boundaries=1, init=0; - if (init==0) - { init=1; - char *s=getenv("LIBCTL_EXCLUDE_BOUNDARIES"); - if (s && s[0]=='1') include_boundaries=0; - } + static boolean include_boundaries = 1, init = 0; + if (init == 0) { + init = 1; + char *s = getenv("LIBCTL_EXCLUDE_BOUNDARIES"); + if (s && s[0] == '1') include_boundaries = 0; + } return point_in_or_on_prism(prsm, pc, include_boundaries); } - // comparator for qsort -static int dcmp(const void *pd1, const void *pd2) -{ double d1=*((double *)pd1), d2=*((double *)pd2); - return (d1d2) ? 1.0 : 0.0; +static int dcmp(const void *pd1, const void *pd2) { + double d1 = *((double *)pd1), d2 = *((double *)pd2); + return (d1 < d2) ? -1.0 : (d1 > d2) ? 1.0 : 0.0; } /******************************************************************/ @@ -2359,89 +2147,101 @@ /* the intersection s-values sorted in ascending order. */ /* the return value is the number of intersections. */ /******************************************************************/ -int intersect_line_with_prism(prism *prsm, vector3 pc, vector3 dc, double *slist) -{ - vector3 pp = prism_coordinate_c2p(prsm,pc); - vector3 dp = prism_vector_c2p(prsm,dc); - vector3 *vps = prsm->vertices_p.items; +int intersect_line_with_prism(prism *prsm, vector3 pc, vector3 dc, double *slist) { + vector3 pp = prism_coordinate_c2p(prsm, pc); + vector3 dp = prism_vector_c2p(prsm, dc); + vector3 *vps_bottom = prsm->vertices_p.items; + vector3 *vps_top = prsm->vertices_top_p.items; int num_vertices = prsm->vertices_p.num_items; - double height = prsm->height; - - // use length of first polygon edge as a length scale for judging - // lengths to be small or large - double length_scale = vector3_norm(vector3_minus(vps[1], vps[0])); + double height = prsm->height; // identify intersections with prism side faces - int num_intersections=0; + double tus_tolerance = 1e-8; + int num_intersections = 0; int nv; - for(nv=0; nvzp_max) ) - continue; - - slist[num_intersections++]=s; - } + for (nv = 0; nv < num_vertices; nv++) { + int nvp1 = nv + 1; + if (nvp1 == num_vertices) nvp1 = 0; + + // checks if dp is parallel to the plane of the prism side face under consideration + vector3 v1 = vector3_minus(vps_bottom[nvp1], vps_bottom[nv]); + vector3 v2 = vector3_minus(vps_top[nv], vps_bottom[nv]); + double dot_tolerance = 1e-6; + if (fabs(vector3_dot(dp, vector3_cross(v1, v2))) <= dot_tolerance) continue; + + // to find the intersection point pp + s*dp between the line and the + // prism side face, we will solve the vector equation + // pp + s*dp = o + t*v1 + u*v2 + // where o is vps_bottom[nv], v1 is vps_bottom[nvp1]-vps_bottom[nv], + // v2 is vps_top[nv]-vps_bottom[nv], and 0 <= t <= 1, 0 <= u <= 1. + matrix3x3 M; + M.c0 = v1; + M.c1 = v2; + M.c2 = vector3_scale(-1, dp); + vector3 RHS = vector3_minus(pp, vps_bottom[nv]); + vector3 tus = matrix3x3_vector3_mult(matrix3x3_inverse(M), RHS); + if (tus.x < -tus_tolerance || tus.x > 1+tus_tolerance || tus.y < -tus_tolerance || tus.y > 1+tus_tolerance) continue; + double s = tus.z; + slist[num_intersections++] = s; + } // identify intersections with prism ceiling and floor faces int LowerUpper; - if ( fabs(dp.z) > 1.0e-7*vector3_norm(dp) ) - for(LowerUpper=0; LowerUpper<2; LowerUpper++) - { double z0p = LowerUpper ? height : 0.0; - double s = (z0p - pp.z)/dp.z; - if (!node_in_polygon(pp.x+s*dp.x, pp.y+s*dp.y, vps, num_vertices)) - continue; - slist[num_intersections++]=s; + if (fabs(dp.z) > 1.0e-7 * vector3_norm(dp)) + for (LowerUpper = 0; LowerUpper < 2; LowerUpper++) { + double z0p = LowerUpper ? height : 0.0; + double s = (z0p - pp.z) / dp.z; + vector3 *vps = LowerUpper ? vps_top : vps_bottom; + if (!node_in_polygon(pp.x + s * dp.x, pp.y + s * dp.y, vps, num_vertices)) continue; + slist[num_intersections++] = s; } - qsort((void *)slist,num_intersections,sizeof(double),dcmp); - return num_intersections; + qsort((void *)slist, num_intersections, sizeof(double), dcmp); + // if num_intersections is zero then just return that + if (num_intersections == 0) return num_intersections; + else { + // remove duplicates from slist + double duplicate_tolerance = 1e-3; + int num_unique_elements = 1; + double slist_unique[num_vertices+2]; + slist_unique[0] = slist[0]; + for (nv = 1; nv < num_intersections; nv++) { + if (fabs(slist[nv] - slist[nv-1]) > duplicate_tolerance*fabs(slist[nv])) { + slist_unique[num_unique_elements] = slist[nv]; + num_unique_elements++; + } + } + slist = slist_unique; + num_intersections = num_unique_elements; + return num_intersections; + } } /***************************************************************/ /***************************************************************/ /***************************************************************/ -double intersect_line_segment_with_prism(prism *prsm, vector3 pc, vector3 dc, double a, double b) -{ - double *slist=prsm->workspace.items; - int num_intersections=intersect_line_with_prism(prsm, pc, dc, slist); +double intersect_line_segment_with_prism(prism *prsm, vector3 pc, vector3 dc, double a, double b) { + double *slist = prsm->workspace.items; + int num_intersections = intersect_line_with_prism(prsm, pc, dc, slist); // na=smallest index such that slist[na] > a - int na=-1; + int na = -1; int ns; - for(ns=0; na==-1 && nsa) - na=ns; - - if (na==-1) - return 0.0; - - int inside = ( (na%2)==0 ? 0 : 1); - double last_s=a; - double ds=0.0; - for(ns=na; ns a) na = ns; + + if (na == -1) return 0.0; + + int inside = ((na % 2) == 0 ? 0 : 1); + double last_s = a; + double ds = 0.0; + for (ns = na; ns < num_intersections; ns++) { + double this_s = fmin(b, slist[ns]); + if (inside) ds += (this_s - last_s); + if (b < slist[ns]) break; + inside = (1 - inside); + last_s = this_s; + } return ds > 0.0 ? ds : 0.0; } @@ -2454,14 +2254,14 @@ /* --> 2d |v2-v1|^2 - 2*dot(p-v1,v2-v1) = 0 */ /* --> d = dot(p-v1,v2-v1) / |v2-v1|^2 */ /***************************************************************/ -double min_distance_to_line_segment(vector3 p, vector3 v1, vector3 v2) -{ vector3 v2mv1 = vector3_minus(v2,v1); - vector3 pmv1 = vector3_minus(p,v1); - double d = vector3_dot(v2mv1,pmv1) / vector3_dot(v2mv1,v2mv1); - if (d<0.0) d=0.0; // if pProj lies outside the line segment, - if (d>1.0) d=1.0; // displace it to whichever vertex is closer - vector3 pLine = vector3_plus(v1, vector3_scale(d,v2mv1)); - return vector3_norm(vector3_minus(p,pLine)); +double min_distance_to_line_segment(vector3 p, vector3 v1, vector3 v2) { + vector3 v2mv1 = vector3_minus(v2, v1); + vector3 pmv1 = vector3_minus(p, v1); + double d = vector3_dot(v2mv1, pmv1) / vector3_dot(v2mv1, v2mv1); + if (d < 0.0) d = 0.0; // if pProj lies outside the line segment, + if (d > 1.0) d = 1.0; // displace it to whichever vertex is closer + vector3 pLine = vector3_plus(v1, vector3_scale(d, v2mv1)); + return vector3_norm(vector3_minus(p, pLine)); } /***************************************************************/ @@ -2479,61 +2279,65 @@ /* or 1 according as pPlane does or does not lie in the */ /* quadrilateral with vertices (o, o+v1, o+v2, o+v1+v2). */ /***************************************************************/ -double normal_distance_to_plane(vector3 p, - vector3 o, vector3 v1, vector3 v2, vector3 v3, - int *in_quadrilateral) -{ - CHECK( (vector3_norm(v3)>1.0e-6), "degenerate plane in project_point_into_plane" ); +double normal_distance_to_plane(vector3 p, vector3 o, vector3 v1, vector3 v2, vector3 v3, + int *in_quadrilateral) { + CHECK((vector3_norm(v3) > 1.0e-6), "degenerate plane in project_point_into_plane"); matrix3x3 M; M.c0 = v1; M.c1 = v2; M.c2 = v3; - vector3 RHS = vector3_minus(p,o); - vector3 tus = matrix3x3_vector3_mult(matrix3x3_inverse(M),RHS); // "t, u, s" - float t=tus.x, u=tus.y, s=tus.z; + vector3 RHS = vector3_minus(p, o); + vector3 tus = matrix3x3_vector3_mult(matrix3x3_inverse(M), RHS); // "t, u, s" + float t = tus.x, u = tus.y, s = tus.z; if (in_quadrilateral) - *in_quadrilateral = ( ( 0.0<=t && t<=1.0 && 0.0<=u && u<=1.0 ) ? 1 : 0 ); + *in_quadrilateral = ((0.0 <= t && t <= 1.0 && 0.0 <= u && u <= 1.0) ? 1 : 0); return s; } // like normal_distance_to_plane, but if pPlane (projection of point into plane) // lies outside the quadrilateral {o,o+v1,o+v2,o+v1+v2} then take into account // the in-plane distance from pPlane to the quadrilateral -double min_distance_to_quadrilateral(vector3 p, - vector3 o, vector3 v1, vector3 v2, vector3 v3) -{ +double min_distance_to_quadrilateral(vector3 p, vector3 o, vector3 v1, vector3 v2, vector3 v3) { int inside; - double s=normal_distance_to_plane(p, o, v1, v2, v3, &inside); - if(inside==1) - return s; - vector3 pPlane = vector3_minus(p, vector3_scale(s,v3) ); - vector3 p01 = vector3_plus(o,v1); - vector3 p10 = vector3_plus(o,v2); - vector3 p11 = vector3_plus(p01,v2); - double d = min_distance_to_line_segment(pPlane, o, p01) ; - d = fmin(d, min_distance_to_line_segment(pPlane, o, p10) ); - d = fmin(d, min_distance_to_line_segment(pPlane, p01, p11) ); - d = fmin(d, min_distance_to_line_segment(pPlane, p11, p10) ); - return sqrt(s*s+d*d); + double s = normal_distance_to_plane(p, o, v1, v2, v3, &inside); + if (inside == 1) return s; + vector3 pPlane = vector3_minus(p, vector3_scale(s, v3)); + vector3 p01 = vector3_plus(o, v1); + vector3 p10 = vector3_plus(o, v2); + vector3 p11 = vector3_plus(p01, v2); + double d = min_distance_to_line_segment(pPlane, o, p01); + d = fmin(d, min_distance_to_line_segment(pPlane, o, p10)); + d = fmin(d, min_distance_to_line_segment(pPlane, p01, p11)); + d = fmin(d, min_distance_to_line_segment(pPlane, p11, p10)); + return sqrt(s * s + d * d); } // fc==0/1 for floor/ceiling -double min_distance_to_prism_roof_or_ceiling(vector3 pp, prism *prsm, int fc) -{ - vector3 *vps = prsm->vertices_p.items; - int num_vertices = prsm->vertices_p.num_items; - vector3 op = {0.0,0.0,0.0}; if (fc==1) op.z = prsm->height; // origin of floor/ceiling - vector3 zhatp = {0,0,1.0}; - double s = normal_distance_to_plane(pp,op,vps[0],vps[1],zhatp,0); - vector3 ppProj = vector3_minus(pp, vector3_scale(s,zhatp) ); // projection of p into plane of floor/ceiling - if (node_in_polygon(ppProj.x,ppProj.y,vps,num_vertices)==1) - return s; +double min_distance_to_prism_roof_or_ceiling(vector3 pp, prism *prsm, int fc) { + int num_vertices = prsm->vertices_p.num_items, i; + vector3 op = {0.0, 0.0, 0.0}; // origin of floor/ceiling + vector3 vps[num_vertices]; + if (fc == 1) { + memcpy(vps, prsm->vertices_top_p.items, num_vertices * sizeof(vector3)); + for (i = 0; i < num_vertices; i++) { + vps[i].z = 0; + } + op.z = prsm->height; + } + else { + memcpy(vps, prsm->vertices_p.items, num_vertices * sizeof(vector3)); + } + vector3 zhatp = {0, 0, 1.0}; + double s = normal_distance_to_plane(pp, op, vps[0], vps[1], zhatp, 0); + vector3 ppProj = + vector3_minus(pp, vector3_scale(s, zhatp)); // projection of p into plane of floor/ceiling + if (node_in_polygon(ppProj.x, ppProj.y, vps, num_vertices) == 1) return s; int nv; - double d=min_distance_to_line_segment(ppProj,vps[0],vps[1] ); - for(nv=1; nvheight==0.0) - return prsm->axis; +vector3 normal_to_prism(prism *prsm, vector3 pc) { + if (prsm->height == 0.0) return prsm->axis; - double height = prsm->height; - vector3 *vps = prsm->vertices_p.items; + double height = prsm->height; + vector3 *vps_bottom = prsm->vertices_p.items; + vector3 *vps_diff_to_top = prsm->top_polygon_diff_vectors_p.items; int num_vertices = prsm->vertices_p.num_items; - vector3 zhatp = {0.0, 0.0, 1.0}; - vector3 axisp = vector3_scale(height, zhatp); - vector3 pp = prism_coordinate_c2p(prsm, pc); + vector3 zhatp = {0.0, 0.0, 1.0}; + vector3 axisp = vector3_scale(height, zhatp); + vector3 pp = prism_coordinate_c2p(prsm, pc); vector3 retval; - double min_distance=HUGE_VAL; + double min_distance = HUGE_VAL; int nv; // consider side walls - for(nv=0; nvsidewall_angle == 0.0) { + return get_area_of_polygon_from_nodes(prsm->vertices_p.items, prsm->vertices_p.num_items) * fabs(prsm->height); + } + else { + int num_vertices = prsm->vertices_p.num_items, nv; + double bottom_polygon_area = get_area_of_polygon_from_nodes(prsm->vertices_p.items, prsm->vertices_p.num_items); + double top_polygon_area = get_area_of_polygon_from_nodes(prsm->vertices_top_p.items, prsm->vertices_top_p.num_items); + double volume; + vector3 *wedges_a; + wedges_a = (vector3 *)malloc(num_vertices * sizeof(vector3)); + CHECK(wedges_a, "out of memory"); + vector3 *wedges_b; + wedges_b = (vector3 *)malloc(num_vertices * sizeof(vector3)); + CHECK(wedges_b, "out of memory"); + vector3 *wedges_c; + wedges_c = (vector3 *)malloc(num_vertices * sizeof(vector3)); + CHECK(wedges_c, "out of memory"); + if (bottom_polygon_area > top_polygon_area) { + volume = fabs(top_polygon_area * prsm->height); + memcpy(wedges_a, prsm->vertices_top_p.items, num_vertices * sizeof(vector3)); + memcpy(wedges_b, prsm->vertices_top_p.items, num_vertices * sizeof(vector3)); + for (nv = 0; nv < num_vertices; nv++) { + wedges_b[nv].z = 0.0; + } + memcpy(wedges_c, prsm->vertices_p.items, num_vertices * sizeof(vector3)); + } + else { + volume = fabs(bottom_polygon_area * prsm->height); + memcpy(wedges_a, prsm->vertices_p.items, num_vertices * sizeof(vector3)); + memcpy(wedges_b, prsm->vertices_p.items, num_vertices * sizeof(vector3)); + for (nv = 0; nv < num_vertices; nv++) { + wedges_b[nv].z = prsm->height; + } + memcpy(wedges_c, prsm->vertices_top_p.items, num_vertices * sizeof(vector3)); + } + for (nv = 0; nv < num_vertices; nv++) { + int nvp1 = (nv + 1 == num_vertices ? 0 : nv + 1); + volume += get_volume_irregular_triangular_prism(wedges_a[nv], wedges_b[nv], wedges_c[nv], wedges_a[nvp1], wedges_b[nvp1], wedges_c[nvp1]); + } + return volume; + } +} + +/***************************************************************/ /***************************************************************/ /***************************************************************/ -void get_prism_bounding_box(prism *prsm, geom_box *box) -{ +void get_prism_bounding_box(prism *prsm, geom_box *box) { vector3 *vertices = prsm->vertices.items; - int num_vertices = prsm->vertices.num_items; + vector3 *vertices_top = prsm->vertices_top.items; + int num_vertices = prsm->vertices.num_items; box->low = box->high = vertices[0]; int nv, fc; - for(nv=0; nvheight, prsm->axis) ); - - box->low.x = fmin(box->low.x, v.x); - box->low.y = fmin(box->low.y, v.y); - box->low.z = fmin(box->low.z, v.z); - - box->high.x = fmax(box->high.x, v.x); - box->high.y = fmax(box->high.y, v.y); - box->high.z = fmax(box->high.z, v.z); - } + for (nv = 0; nv < num_vertices; nv++) + for (fc = 0; fc < 2; fc++) // 'floor,ceiling' + { + vector3 v; + if (fc == 0) v = vertices[nv]; + if (fc == 1) v = vertices_top[nv]; + + box->low.x = fmin(box->low.x, v.x); + box->low.y = fmin(box->low.y, v.y); + box->low.z = fmin(box->low.z, v.z); + + box->high.x = fmax(box->high.x, v.x); + box->high.y = fmax(box->high.y, v.y); + box->high.z = fmax(box->high.z, v.z); + } } /***************************************************************/ /***************************************************************/ /***************************************************************/ -void display_prism_info(int indentby, geometric_object *o) -{ +void display_prism_info(int indentby, geometric_object *o) { prism *prsm = o->subclass.prism_data; - vector3 *vs = prsm->vertices.items; + vector3 *vs = prsm->vertices.items; int num_vertices = prsm->vertices.num_items; - ctl_printf("%*s height %g, axis (%g,%g,%g), %i vertices:\n", - indentby, "",prsm->height,prsm->axis.x,prsm->axis.y,prsm->axis.z,num_vertices); + ctl_printf("%*s height %g, axis (%g,%g,%g), sidewall angle: %g radians, %i vertices:\n", indentby, "", prsm->height, + prsm->axis.x, prsm->axis.y, prsm->axis.z, prsm->sidewall_angle, num_vertices); int nv; - for(nv=0; nvprism that are assumed to */ -/* be initialized are: vertices, height, and (optionally) axis.*/ -/* If axis has not been initialized (i.e. it is set to its */ -/* default value, which is the zero vector) then the prism axis*/ -/* is automatically computed as the normal to the vertex plane.*/ -/* If o->center is equal to auto_center on entry, then it is */ -/* set to the prism center, as computed from the vertices, */ -/* axis, and height. Otherwise, the prism is rigidly translated*/ -/* to center it at the specified value of o->center. */ +/* be initialized are: vertices, height, (optionally) */ +/* axis, and sidewall_angle. If axis has not been initialized */ +/* (i.e. it is set to its default value, which is the zero */ +/* vector) then the prism axis is automatically computed as */ +/* the normal to the vertex plane. If o->center is equal to */ +/* auto_center on entry, then it is set to the prism center, */ +/* as computed from the vertices, axis, and height. Otherwise, */ +/* the prism is rigidly translated to center it at the */ +/* specified value of o->center. */ /***************************************************************/ // special vector3 that signifies 'no value specified' -vector3 auto_center = { NAN, NAN, NAN }; -void init_prism(geometric_object *o) -{ - prism *prsm = o->subclass.prism_data; +vector3 auto_center = {NAN, NAN, NAN}; +void init_prism(geometric_object *o) { + prism *prsm = o->subclass.prism_data; vector3 *vertices = prsm->vertices.items; - int num_vertices = prsm->vertices.num_items; - CHECK(num_vertices>=3, "fewer than 3 vertices in init_prism"); + int num_vertices = prsm->vertices.num_items; + CHECK(num_vertices >= 3, "fewer than 3 vertices in init_prism"); // compute centroid of vertices vector3 centroid = {0.0, 0.0, 0.0}; int nv; - for(nv=0; nvcentroid = centroid = vector3_scale(1.0/((double)num_vertices), centroid); + for (nv = 0; nv < num_vertices; nv++) + centroid = vector3_plus(centroid, vertices[nv]); + prsm->centroid = centroid = vector3_scale(1.0 / ((double)num_vertices), centroid); // make sure all vertices lie in a plane, i.e. that the normal // vectors to all triangles (v_n, v_{n+1}, centroid) agree. - int plane_normal_set=0; + int plane_normal_set = 0; vector3 plane_normal; - double tol=1.0e-6; - for(nv=0; nvaxis) == 0.0 ) - prsm->axis = plane_normal; - else - { prsm->axis = unit_vector3(prsm->axis); - boolean axis_normal_to_plane - = ( vector3_nearly_equal(prsm->axis, plane_normal, tol) - || vector3_nearly_equal(prsm->axis, vector3_scale(-1.0,plane_normal), tol) - ); - CHECK(axis_normal_to_plane, "axis not normal to vertex plane in init_prism"); - } + if (vector3_norm(prsm->axis) == 0.0) + prsm->axis = plane_normal; + else { + prsm->axis = unit_vector3(prsm->axis); + boolean axis_normal_to_plane = + (vector3_nearly_equal(prsm->axis, plane_normal, tol) || + vector3_nearly_equal(prsm->axis, vector3_scale(-1.0, plane_normal), tol)); + CHECK(axis_normal_to_plane, "axis not normal to vertex plane in init_prism"); + } // set current_center=prism center as determined by vertices and height. // if the center of the geometric object was left unspecified, // set it to current_center; otherwise displace the entire prism // so that it is centered at the specified center. - vector3 current_center = vector3_plus(centroid, vector3_scale(0.5*prsm->height,prsm->axis) ); + vector3 current_center = vector3_plus(centroid, vector3_scale(0.5 * prsm->height, prsm->axis)); if (isnan(o->center.x) && isnan(o->center.y) && isnan(o->center.z)) // center == auto-center - o->center = current_center; - else - { vector3 shift = vector3_minus(o->center, current_center); - for(nv=0; nvcenter = current_center; + else { + vector3 shift = vector3_minus(o->center, current_center); + for (nv = 0; nv < num_vertices; nv++) + vertices[nv] = vector3_plus(vertices[nv], shift); + centroid = vector3_plus(centroid, shift); + } // compute rotation matrix that operates on a vector of cartesian coordinates // to yield the coordinates of the same point in the prism coordinate system. @@ -2733,55 +2637,217 @@ // This is the origin of coordinates in the prism system. // The *center* of the geometric object is the center of mass of the // 3D prism. So center = centroid + 0.5*height*zHat. - vector3 x0hat={1.0,0.0,0.0}, y0hat={0.0,1.0,0.0}, z0hat={0.0,0.0,1.0}; - vector3 xhat, yhat, zhat=prsm->axis; - if (vector3_nearly_equal(zhat, x0hat, tol)) { xhat=y0hat; yhat=z0hat; } - else if (vector3_nearly_equal(zhat, y0hat, tol)) { xhat=z0hat; yhat=x0hat; } - else if (vector3_nearly_equal(zhat, z0hat, tol)) { xhat=x0hat; yhat=y0hat; } - else - { xhat = unit_vector3(vector3_minus(vertices[1],vertices[0])); - yhat = unit_vector3(vector3_cross(zhat,xhat)); - } + vector3 x0hat = {1.0, 0.0, 0.0}, y0hat = {0.0, 1.0, 0.0}, z0hat = {0.0, 0.0, 1.0}; + vector3 xhat, yhat, zhat = prsm->axis; + if (vector3_nearly_equal(zhat, x0hat, tol)) { + xhat = y0hat; + yhat = z0hat; + } + else if (vector3_nearly_equal(zhat, y0hat, tol)) { + xhat = z0hat; + yhat = x0hat; + } + else if (vector3_nearly_equal(zhat, z0hat, tol)) { + xhat = x0hat; + yhat = y0hat; + } + else { + xhat = unit_vector3(vector3_minus(vertices[1], vertices[0])); + yhat = unit_vector3(vector3_cross(zhat, xhat)); + } matrix3x3 m_p2c = {xhat, yhat, zhat}; - prsm->m_p2c = m_p2c; - prsm->m_c2p = matrix3x3_inverse(m_p2c); + prsm->m_p2c = m_p2c; + prsm->m_c2p = matrix3x3_inverse(m_p2c); // compute vertices in prism coordinate system prsm->vertices_p.num_items = num_vertices; - prsm->vertices_p.items = (vector3 *)malloc(num_vertices*sizeof(vector3)); - for(nv=0; nvvertices_p.items[nv] = prism_coordinate_c2p(prsm,vertices[nv]); + prsm->vertices_p.items = (vector3 *)malloc(num_vertices * sizeof(vector3)); + for (nv = 0; nv < num_vertices; nv++) + prsm->vertices_p.items[nv] = prism_coordinate_c2p(prsm, vertices[nv]); + + // Calculate difference vertices of the top polygon and vectors between bottom + // polygon and the top polygon, where: + // * the bottom polygon is the one passed in to the the make_prism() function, + // stored in vertices and vertices_p, + // * the top polygon is the top surface (parallel to the bottom polygon) resulting + // from the extrusion of the bottom polygon. Whether or not the extrusion tapers + // is dependent on the value of sidewall_angle. + // + // The top polygon is calculated by first copying the values of vertices_p into + // vertices_top_p, except z=prsm->height for all top vertices. If prsm->sidewall_angle + // is equal to zero, then no further calculations are performed on the top vertices. + // If not, we know that all EDGES of the the top polygon will be offset so that in the + // xy plane they are parallel to the edges of the bottom polygon. The offset amount is + // determined by the sidewall angle and the height of the prism. To perform the + // calculation, each of the edges of the top polygon (without an offset) are stored in + // an array of edges (edge is a struct defined if prsm->sidewall_angle!=0 containing + // the endpoints a1 a2, with a third vector v defined a2-a1). Then the vector normal to + // v is calculated, and the offset vector. A test is performed to determine in which + // direction (the direction of +offset or -offset) from the edge we can find points + // inside the polygon by performing a node_in_or_on_polygon test at a finite distance + // away from the midpoint of the edge: + // edge.a1 + 0.5*edge.v + 1e-3*offset. + // This information is used to determine in which direction the offset of the edge is + // applied, in conjunction with whether prsm->sidewall_angle is positive or negative + // (if positive, the offset will be applied in towards the points where + // node_in_or_on_polygon is true, else the offset will be applied out away from those + // points). After the offsets are applied to the edges, the intersections between the + // new edges are calculated, which are the new values of vertices_top_p. + // + // Some side notes on the difference vectors: + // * The value of each of the top polygon vertices can be found + // vertices_p + top_polygon_diff_vectors_p + // vertices + top_polygon_diff_vectors + // * A linearly interpolated value of the polygon vertices between the bottom + // polygon and the top can be found + // vertices_p + top_polygon_diff_vectors_scaled_p * z + number theta = (K_PI/2) - fabs(prsm->sidewall_angle); + prsm->vertices_top_p.num_items = num_vertices; + prsm->vertices_top_p.items = (vector3 *)malloc(num_vertices * sizeof(vector3)); + CHECK(prsm->vertices_top_p.items, "out of memory"); + memcpy(prsm->vertices_top_p.items, prsm->vertices_p.items, num_vertices * sizeof(vector3)); + for (nv = 0; nv < num_vertices; nv++) { + prsm->vertices_top_p.items[nv].z = prsm->height; + } + + if (prsm->sidewall_angle != 0.0) { + typedef struct { + vector3 a1, a2, v; // v will be defined as a2 - a1 + } edge; + + // find the point at the bottom left corner of the polygon + double smallest_x = HUGE_VAL; + double smallest_y = HUGE_VAL; + int index_for_point_a = -1; + int index_for_point_b = -1; + int index_for_point_c = -1; + for (nv = 0; nv < num_vertices; nv++) { + double current_x = prsm->vertices_p.items[nv].x; + double current_y = prsm->vertices_p.items[nv].y; + if (current_x < smallest_x) { + smallest_x = current_x; + smallest_y = current_y; + index_for_point_b = nv; + } + else if (current_x == smallest_x && current_y < smallest_y) { + smallest_y = current_y; + index_for_point_b = nv; + } + } + if (index_for_point_b == -1) { + exit(EXIT_FAILURE); + } + else { + index_for_point_a = (index_for_point_b + 1 == num_vertices ? 0 : index_for_point_b + 1); + index_for_point_c = (index_for_point_b - 1 == -1 ? num_vertices - 1 : index_for_point_b - 1); + } + // find orientation of the polygon + vector3 A = prsm->vertices_p.items[index_for_point_a]; + vector3 B = prsm->vertices_p.items[index_for_point_b]; + vector3 C = prsm->vertices_p.items[index_for_point_c]; + double orientation_number = (B.x - A.x)*(C.y - A.y)-(C.x - A.x)*(B.y - A.y); + int orientation_positive_or_negative = (orientation_number < 0 ? 0 : 1); + + edge *top_polygon_edges; + top_polygon_edges = (edge *)malloc(num_vertices * sizeof(edge)); + number w = prsm->height / tan(theta); + + for (nv = 0; nv < num_vertices; nv++) { + top_polygon_edges[nv].a1 = prsm->vertices_top_p.items[(nv - 1 == -1 ? num_vertices - 1 : nv - 1)]; + top_polygon_edges[nv].a2 = prsm->vertices_top_p.items[nv]; + top_polygon_edges[nv].v = vector3_minus(top_polygon_edges[nv].a2, top_polygon_edges[nv].a1); + + vector3 normal_vector = (orientation_positive_or_negative ? unit_vector3(vector3_cross(top_polygon_edges[nv].v, zhat)) : unit_vector3(vector3_cross(top_polygon_edges[nv].v, vector3_scale(-1, zhat)))); + + // positive sidewall angles means the prism tapers in towards the rest of the prism body + // negative sidewall angles means the prism tapers out away from the rest of the prism body + vector3 offset = vector3_scale(prsm->sidewall_angle > 0 ? w : -w, normal_vector); + top_polygon_edges[nv].a1 = vector3_plus(top_polygon_edges[nv].a1, offset); + top_polygon_edges[nv].a2 = vector3_plus(top_polygon_edges[nv].a2, offset); + } + + for (nv = 0; nv < num_vertices; nv++) { + number x1 = top_polygon_edges[nv].a1.x; + number y1 = top_polygon_edges[nv].a1.y; + number x2 = top_polygon_edges[nv].a2.x; + number y2 = top_polygon_edges[nv].a2.y; + number x3 = top_polygon_edges[(nv + 1 == num_vertices ? 0 : nv + 1)].a1.x; + number y3 = top_polygon_edges[(nv + 1 == num_vertices ? 0 : nv + 1)].a1.y; + number x4 = top_polygon_edges[(nv + 1 == num_vertices ? 0 : nv + 1)].a2.x; + number y4 = top_polygon_edges[(nv + 1 == num_vertices ? 0 : nv + 1)].a2.y; + + // Intersection point calculated with https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection#Given_two_points_on_each_line + number px = ((x1*y2-y1*x2)*(x3-x4)-(x1-x2)*(x3*y4-y3*x4)) / ((x1-x2)*(y3-y4)-(y1-y2)*(x3-x4)); + number py = ((x1*y2-y1*x2)*(y3-y4)-(y1-y2)*(x3*y4-y3*x4)) / ((x1-x2)*(y3-y4)-(y1-y2)*(x3-x4)); + prsm->vertices_top_p.items[nv].x = px; + prsm->vertices_top_p.items[nv].y = py; + } + } + + prsm->top_polygon_diff_vectors_p.num_items = num_vertices; + prsm->top_polygon_diff_vectors_p.items = (vector3 *)malloc(num_vertices * sizeof(vector3)); + CHECK(prsm->top_polygon_diff_vectors_p.items, "out of memory"); + for (nv = 0; nv < num_vertices; nv++) { + prsm->top_polygon_diff_vectors_p.items[nv] = vector3_minus(prsm->vertices_top_p.items[nv], prsm->vertices_p.items[nv]); + } + + prsm->top_polygon_diff_vectors_scaled_p.num_items = num_vertices; + prsm->top_polygon_diff_vectors_scaled_p.items = (vector3 *)malloc(num_vertices * sizeof(vector3)); + CHECK(prsm->top_polygon_diff_vectors_scaled_p.items, "out of memory"); + for (nv = 0; nv < num_vertices; nv++) { + prsm->top_polygon_diff_vectors_scaled_p.items[nv] = vector3_scale(1/prsm->height, prsm->top_polygon_diff_vectors_p.items[nv]); + } + + prsm->vertices_top.num_items = num_vertices; + prsm->vertices_top.items = (vector3 *)malloc(num_vertices * sizeof(vector3)); + CHECK(prsm->vertices_top.items, "out of memory"); + for (nv = 0; nv < num_vertices; nv++) { + prsm->vertices_top.items[nv] = prism_coordinate_p2c(prsm, prsm->vertices_top_p.items[nv]); + } // workspace is an internally-stored double-valued array of length num_vertices+2 // that is used by some geometry routines - prsm->workspace.num_items = num_vertices+2; - prsm->workspace.items = (double *)malloc( (num_vertices+2)*sizeof(double) ); + prsm->workspace.num_items = num_vertices + 2; + prsm->workspace.items = (double *)malloc((num_vertices + 2) * sizeof(double)); } /***************************************************************/ /* routines called from C++ or python codes to create prisms */ /***************************************************************/ // prism with center determined automatically from vertices, height, and axis -geometric_object make_prism(material_type material, - const vector3 *vertices, int num_vertices, - double height, vector3 axis) -{ return make_prism_with_center(material, auto_center, vertices, num_vertices, height, axis); } - -// prism in which all vertices are translated to ensure that the prism is centered at center -geometric_object make_prism_with_center(material_type material, vector3 center, - const vector3 *vertices, int num_vertices, - double height, vector3 axis) -{ - geometric_object o=make_geometric_object(material, center); - o.which_subclass=GEOM PRISM; +geometric_object make_prism(material_type material, const vector3 *vertices, int num_vertices, + double height, vector3 axis) { + return make_prism_with_center(material, auto_center, vertices, num_vertices, height, axis); +} + +// prism in which all vertices are translated to ensure that the prism is centered at center. +geometric_object make_prism_with_center(material_type material, vector3 center, const vector3 *vertices, + int num_vertices, double height, vector3 axis) { + return make_slanted_prism_with_center(material, center, vertices, num_vertices, height, axis, 0); +} + +// slanted prism with center determined automatically from vertices, height, axis, and sidewall_angle +geometric_object make_slanted_prism(material_type material, const vector3 *vertices, + int num_vertices, double height, vector3 axis, double sidewall_angle) { + return make_slanted_prism_with_center(material, auto_center, vertices, num_vertices, height, axis, sidewall_angle); +} + +// Have both make_prism_with_center and make_slanted_prism_with_center keep the same parameters to maintain ABI +// compatibility, though make_prism_with_center just calls make_slanted_prism_with_center with the sidewall angle equal +// to zero. To make a slanted prism, the user will have to call make_slanted_prism for now. +geometric_object make_slanted_prism_with_center(material_type material, vector3 center, const vector3 *vertices, + int num_vertices, double height, vector3 axis, double sidewall_angle) { + geometric_object o = make_geometric_object(material, center); + o.which_subclass = GEOM PRISM; prism *prsm = o.subclass.prism_data = MALLOC1(prism); CHECK(prsm, "out of memory"); prsm->vertices.num_items = num_vertices; - prsm->vertices.items = (vector3 *)malloc(num_vertices*sizeof(vector3)); + prsm->vertices.items = (vector3 *)malloc(num_vertices * sizeof(vector3)); CHECK(prsm->vertices.items, "out of memory"); - memcpy(prsm->vertices.items, vertices, num_vertices*sizeof(vector3)); + memcpy(prsm->vertices.items, vertices, num_vertices * sizeof(vector3)); prsm->height = height; - prsm->axis = axis; + prsm->axis = axis; + prsm->sidewall_angle = sidewall_angle; init_prism(&o); return o; } diff -Nru libctl-4.4.0/utils/geom-ctl-io-defaults.c libctl-4.5.0/utils/geom-ctl-io-defaults.c --- libctl-4.4.0/utils/geom-ctl-io-defaults.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/geom-ctl-io-defaults.c 2020-02-19 18:34:33.000000000 +0000 @@ -5,16 +5,16 @@ integer dimensions = 3; void *default_material = NULL; -vector3 geometry_center = { 0, 0, 0 }; -lattice geometry_lattice = { { 1,0,0 }, - { 0,1,0 }, - { 0,0,1 }, - { 1e20,1e20,1e20 }, - { 1,1,1 }, - { 1,0,0 }, - { 0,1,0 }, - { 0,0,1 }, - { { 1,0,0 }, { 0,1,0 }, { 0,0,1 } }, - { { 1,0,0 }, { 0,1,0 }, { 0,0,1 } } }; -geometric_object_list geometry = { 0, 0 }; +vector3 geometry_center = {0, 0, 0}; +lattice geometry_lattice = {{1, 0, 0}, + {0, 1, 0}, + {0, 0, 1}, + {1e20, 1e20, 1e20}, + {1, 1, 1}, + {1, 0, 0}, + {0, 1, 0}, + {0, 0, 1}, + {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}, + {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}}; +geometric_object_list geometry = {0, 0}; boolean ensure_periodicity = 0; diff -Nru libctl-4.4.0/utils/geom.scm libctl-4.5.0/utils/geom.scm --- libctl-4.4.0/utils/geom.scm 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/geom.scm 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ ; libctl: flexible Guile-based control files for scientific software -; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson +; Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public @@ -92,17 +92,17 @@ ; some notes regarding prisms: ; (a) When instantiating a prism, typically only the -; fields `vertices`, `height,` and (optionally) `axis` -; will be initialized by the user; all remaining fields are -; derived properties that are computed internally. (So, morally -; they should be thought of as having been declared using -; `define-derived-property` or `define-post-processed-property,` -; except here the code that does the derivation or -; post-processing is implemented in C, not scheme.) +; fields `vertices`, `height,` (optionally) `axis`, +; and `sidewall_angle` will be initialized by the user; all +; remaining fields are derived properties that are computed +; internally. (So, morally, they should be thought of as having +; been declared using `define-derived-property` or +; `define-post-processed-property,` except here the code that does +; the derivation or post-processing is implemented in C, not scheme.) ; (b) The suffix _p (for "prism") is used to identify variables ; that store coordinates of points or components of vectors -; in the prism coordinate system. (The prism coordinate system -; is defined by the condition that the prism axis is the z-axis +; in the prism coordinate system. (The prism coordinate system +; is defined by the condition that the prism axis is the z-axis ; and the prism floor lies in the xy plane at z==0.) Variables ; with no suffix refer to quantities in ordinary 3D space. ; (c) "centroid" refers to the centroid of the prism floor polygon; this is @@ -117,13 +117,23 @@ ; (center = centroid + 0.5*height*axis), so---in contrast to all other ; types of geometric-object---there is no need to specify the `center` ; field when instantiating a prism. +; (f) The sidwall angle determines an angle at which the prism is extruded. +; A positive sidewall angle determines a prism that extrudes inward at +; the given angle, and a negative sidewall angle determines a prisms +; that extrudes outward. This is useful for modeling a prism formed in +; a foundry that cannot grow objects with a perfectly normal sidewall. (define-class prism geometric-object ; fields to be filled in by users (define-property vertices '() (make-list-type 'vector3)) (define-property height 0 'number) (define-property axis (vector3 0 0 0) 'vector3) + (define-property sidewall_angle 0 'number) ; derived fields computed internally (define-property vertices_p '() (make-list-type 'vector3)) + (define-property top_polygon_diff_vectors_p '() (make-list-type 'vector3)) + (define-property top_polygon_diff_vectors_scaled_p '() (make-list-type 'vector3)) + (define-property vertices_top_p '() (make-list-type 'vector3)) + (define-property vertices_top '() (make-list-type 'vector3)) (define-property centroid (vector3 0 0 0) 'vector3) (define-property workspace '() (make-list-type 'number)) (define-property m_c2p identity_matrix 'matrix3x3) diff -Nru libctl-4.4.0/utils/geomtst.c libctl-4.5.0/utils/geomtst.c --- libctl-4.4.0/utils/geomtst.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/geomtst.c 2020-02-19 18:34:33.000000000 +0000 @@ -8,296 +8,252 @@ /************************************************************************/ /* return a random number in [0,1]: */ -static double mydrand(void) -{ - double d = rand(); - return (d / (double) RAND_MAX); +static double mydrand(void) { + double d = rand(); + return (d / (double)RAND_MAX); } /* return a uniform random number in [a,b] */ -static double myurand(double a, double b) -{ - return ((b - a) * mydrand() + a); -} +static double myurand(double a, double b) { return ((b - a) * mydrand() + a); } #define K_PI 3.141592653589793238462643383279502884197 /* return a random unit vector, uniformly distributed over a sphere */ -vector3 random_unit_vector3(void) -{ - double z, t, r; - vector3 v; - - z = 2*mydrand() - 1; - t = 2*K_PI*mydrand(); - r = sqrt(1 - z*z); - v.x = r * cos(t); - v.y = r * sin(t); - v.z = z; - return v; -} - -double find_edge(geometric_object o, vector3 dir, double max, double tol) -{ - double min = 0; - if (!(point_in_fixed_objectp(vector3_scale(min, dir), o) && - !point_in_fixed_objectp(vector3_scale(max, dir), o))) { - fprintf(stderr, "object out of bounds in find_edge"); - exit(1); - } - do { - double d = (min + max) / 2; - if (point_in_fixed_objectp(vector3_scale(d, dir), o)) - min = d; - else - max = d; - } while (max - min > tol); - return (min + max) / 2; -} - -static vector3 make_vector3(double x, double y, double z) -{ - vector3 v; - v.x = x; v.y = y; v.z = z; - return v; +vector3 random_unit_vector3(void) { + double z, t, r; + vector3 v; + + z = 2 * mydrand() - 1; + t = 2 * K_PI * mydrand(); + r = sqrt(1 - z * z); + v.x = r * cos(t); + v.y = r * sin(t); + v.z = z; + return v; +} + +double find_edge(geometric_object o, vector3 dir, double max, double tol) { + double min = 0; + if (!(point_in_fixed_objectp(vector3_scale(min, dir), o) && + !point_in_fixed_objectp(vector3_scale(max, dir), o))) { + fprintf(stderr, "object out of bounds in find_edge"); + exit(1); + } + do { + double d = (min + max) / 2; + if (point_in_fixed_objectp(vector3_scale(d, dir), o)) + min = d; + else + max = d; + } while (max - min > tol); + return (min + max) / 2; +} + +static vector3 make_vector3(double x, double y, double z) { + vector3 v; + v.x = x; + v.y = y; + v.z = z; + return v; } /* return a random geometric object, centered at the origin, with diameter roughly 1 */ -geometric_object random_object(void) -{ - void* m = NULL; - vector3 c = { 0, 0, 0 }; - geometric_object o; - switch (rand() % 5) { - case 0: - o = make_sphere(m, c, myurand(0.5,1.5)); - break; - case 1: - o = make_cylinder(m, c, myurand(0.5,1.5), myurand(0.5,1.5), - random_unit_vector3()); - break; - case 2: - o = make_cone(m, c, myurand(0.5,1.5), myurand(0.5,1.5), - random_unit_vector3(), myurand(0.5,1.5)); - break; - case 3: - o = make_block(m, c, +geometric_object random_object(void) { + void *m = NULL; + vector3 c = {0, 0, 0}; + geometric_object o; + switch (rand() % 5) { + case 0: o = make_sphere(m, c, myurand(0.5, 1.5)); break; + case 1: + o = make_cylinder(m, c, myurand(0.5, 1.5), myurand(0.5, 1.5), random_unit_vector3()); + break; + case 2: + o = make_cone(m, c, myurand(0.5, 1.5), myurand(0.5, 1.5), random_unit_vector3(), + myurand(0.5, 1.5)); + break; + case 3: + o = make_block(m, c, #if 1 - random_unit_vector3(), - random_unit_vector3(), - random_unit_vector3(), + random_unit_vector3(), random_unit_vector3(), random_unit_vector3(), #else - make_vector3(1,0,0), - make_vector3(0,1,0), - make_vector3(0,0,1), + make_vector3(1, 0, 0), make_vector3(0, 1, 0), make_vector3(0, 0, 1), #endif - make_vector3(myurand(0.5,1.5), - myurand(0.5,1.5), - myurand(0.5,1.5))); - break; - case 4: - o = make_ellipsoid(m, c, - random_unit_vector3(), - random_unit_vector3(), - random_unit_vector3(), - make_vector3(myurand(0.5,1.5), - myurand(0.5,1.5), - myurand(0.5,1.5))); - break; - } - return o; + make_vector3(myurand(0.5, 1.5), myurand(0.5, 1.5), myurand(0.5, 1.5))); + break; + case 4: + o = make_ellipsoid(m, c, random_unit_vector3(), random_unit_vector3(), random_unit_vector3(), + make_vector3(myurand(0.5, 1.5), myurand(0.5, 1.5), myurand(0.5, 1.5))); + break; + } + return o; } /************************************************************************/ static double z1(double x) { return (x == 0 ? 1.0 : x); } -static double simple_overlap(geom_box b, geometric_object o, double tol) -{ - double d1,d2,d3, x1,x2,x3, olap0 = 0; - double itol = 1.0 / ((int) (1/tol + 0.5)); - - d1 = (b.high.x - b.low.x) * itol; - d2 = (b.high.y - b.low.y) * itol; - d3 = (b.high.z - b.low.z) * itol; - for (x1 = b.low.x + d1*0.5; x1 <= b.high.x; x1 += d1+(b.high.x==b.low.x)) - for (x2 = b.low.y + d2*0.5; x2 <= b.high.y; x2 += d2+(b.high.y==b.low.y)) - for (x3 = b.low.z + d3*0.5; x3 <= b.high.z; x3 += d3+(b.high.z==b.low.z)){ - vector3 v; - v.x = x1; v.y = x2; v.z = x3; - olap0 += z1(d1)*z1(d2)*z1(d3) * point_in_fixed_objectp(v, o); - } - olap0 /= z1(b.high.x-b.low.x) * z1(b.high.y-b.low.y) * z1(b.high.z-b.low.z); - return olap0; +static double simple_overlap(geom_box b, geometric_object o, double tol) { + double d1, d2, d3, x1, x2, x3, olap0 = 0; + double itol = 1.0 / ((int)(1 / tol + 0.5)); + + d1 = (b.high.x - b.low.x) * itol; + d2 = (b.high.y - b.low.y) * itol; + d3 = (b.high.z - b.low.z) * itol; + for (x1 = b.low.x + d1 * 0.5; x1 <= b.high.x; x1 += d1 + (b.high.x == b.low.x)) + for (x2 = b.low.y + d2 * 0.5; x2 <= b.high.y; x2 += d2 + (b.high.y == b.low.y)) + for (x3 = b.low.z + d3 * 0.5; x3 <= b.high.z; x3 += d3 + (b.high.z == b.low.z)) { + vector3 v; + v.x = x1; + v.y = x2; + v.z = x3; + olap0 += z1(d1) * z1(d2) * z1(d3) * point_in_fixed_objectp(v, o); + } + olap0 /= z1(b.high.x - b.low.x) * z1(b.high.y - b.low.y) * z1(b.high.z - b.low.z); + return olap0; } static double sqr(double x) { return x * x; } -static double simple_ellip_overlap(geom_box b, geometric_object o, double tol) -{ - double d1,d2,d3, x1,x2,x3, c1,c2,c3, w1,w2,w3, olap0 = 0; - double itol = 1.0 / ((int) (1/tol + 0.5)); - int dim; - - d1 = (b.high.x - b.low.x) * itol; - d2 = (b.high.y - b.low.y) * itol; - d3 = (b.high.z - b.low.z) * itol; - c1 = (b.high.x + b.low.x) * 0.5; - c2 = (b.high.y + b.low.y) * 0.5; - c3 = (b.high.z + b.low.z) * 0.5; - w1 = 2.0 / z1(b.high.x - b.low.x); - w2 = 2.0 / z1(b.high.y - b.low.y); - w3 = 2.0 / z1(b.high.z - b.low.z); - for (x1 = b.low.x + d1*0.5; x1 <= b.high.x; x1 += d1+(b.high.x==b.low.x)) - for (x2 = b.low.y + d2*0.5; x2 <= b.high.y; x2 += d2+(b.high.y==b.low.y)) - for (x3 = b.low.z + d3*0.5; x3 <= b.high.z; x3 += d3+(b.high.z==b.low.z)) - if (sqr((x1 - c1) * w1) + sqr((x2 - c2) * w2) + sqr((x3 - c3) * w3) - < 1.0) { - vector3 v; - v.x = x1; v.y = x2; v.z = x3; - olap0 += z1(d1)*z1(d2)*z1(d3) * point_in_fixed_objectp(v, o); - } - olap0 /= z1(b.high.x-b.low.x) * z1(b.high.y-b.low.y) * z1(b.high.z-b.low.z); - dim = (b.high.x!=b.low.x) + (b.high.y!=b.low.y) + (b.high.z!=b.low.z); - olap0 /= dim == 3 ? 3.14159265358979323846 / 6 : - (dim == 2 ? 3.14159265358979323846 / 4 : 1); - return olap0; -} - -geometric_object random_object_and_lattice(void) -{ - geometric_object o = random_object(); +static double simple_ellip_overlap(geom_box b, geometric_object o, double tol) { + double d1, d2, d3, x1, x2, x3, c1, c2, c3, w1, w2, w3, olap0 = 0; + double itol = 1.0 / ((int)(1 / tol + 0.5)); + int dim; + + d1 = (b.high.x - b.low.x) * itol; + d2 = (b.high.y - b.low.y) * itol; + d3 = (b.high.z - b.low.z) * itol; + c1 = (b.high.x + b.low.x) * 0.5; + c2 = (b.high.y + b.low.y) * 0.5; + c3 = (b.high.z + b.low.z) * 0.5; + w1 = 2.0 / z1(b.high.x - b.low.x); + w2 = 2.0 / z1(b.high.y - b.low.y); + w3 = 2.0 / z1(b.high.z - b.low.z); + for (x1 = b.low.x + d1 * 0.5; x1 <= b.high.x; x1 += d1 + (b.high.x == b.low.x)) + for (x2 = b.low.y + d2 * 0.5; x2 <= b.high.y; x2 += d2 + (b.high.y == b.low.y)) + for (x3 = b.low.z + d3 * 0.5; x3 <= b.high.z; x3 += d3 + (b.high.z == b.low.z)) + if (sqr((x1 - c1) * w1) + sqr((x2 - c2) * w2) + sqr((x3 - c3) * w3) < 1.0) { + vector3 v; + v.x = x1; + v.y = x2; + v.z = x3; + olap0 += z1(d1) * z1(d2) * z1(d3) * point_in_fixed_objectp(v, o); + } + olap0 /= z1(b.high.x - b.low.x) * z1(b.high.y - b.low.y) * z1(b.high.z - b.low.z); + dim = (b.high.x != b.low.x) + (b.high.y != b.low.y) + (b.high.z != b.low.z); + olap0 /= dim == 3 ? 3.14159265358979323846 / 6 : (dim == 2 ? 3.14159265358979323846 / 4 : 1); + return olap0; +} + +geometric_object random_object_and_lattice(void) { + geometric_object o = random_object(); #if 1 - geometry_lattice.basis1 = random_unit_vector3(); - geometry_lattice.basis2 = random_unit_vector3(); - geometry_lattice.basis3 = random_unit_vector3(); - geom_fix_lattice(); - geom_fix_object_ptr(&o); + geometry_lattice.basis1 = random_unit_vector3(); + geometry_lattice.basis2 = random_unit_vector3(); + geometry_lattice.basis3 = random_unit_vector3(); + geom_fix_lattice(); + geom_fix_object_ptr(&o); #endif - return o; + return o; } -static const char *object_name(geometric_object o) -{ - switch (o.which_subclass) { - case CYLINDER: - switch (o.subclass.cylinder_data->which_subclass) { - case WEDGE: return "wedge"; - case CONE: return "cone"; - case CYLINDER_SELF: return "cylinder"; - } - case SPHERE: return "sphere"; - case BLOCK: - switch (o.subclass.block_data->which_subclass) { - case ELLIPSOID: return "ellipsoid"; - case BLOCK_SELF: return "block"; - } - case PRISM: return "prism"; - case COMPOUND_GEOMETRIC_OBJECT: return "compound object"; - default: return "geometric object"; - } -} - -void check_overlap(double tol, double olap0, double olap, int dim, geometric_object o, geom_box b) -{ - if (fabs(olap0 - olap) > 2 * tol * fabs(olap)) { - fprintf(stderr, "Large error %e in overlap (%g vs. %g) for:\n" - " lattice = (%g,%g,%g), (%g,%g,%g), (%g,%g,%g)\n" - " box = (%g,%g,%g) - (%g,%g,%g)\n", - fabs(olap0 - olap) / fabs(olap), - olap, olap0, - geometry_lattice.basis1.x, - geometry_lattice.basis1.y, - geometry_lattice.basis1.z, - geometry_lattice.basis2.x, - geometry_lattice.basis2.y, - geometry_lattice.basis2.z, - geometry_lattice.basis3.x, - geometry_lattice.basis3.y, - geometry_lattice.basis3.z, - b.low.x, b.low.y, b.low.z, - b.high.x, b.high.y, b.high.z); - display_geometric_object_info(2, o); - /* exit(1); */ - } - else - printf("Got %s %dd overlap %g vs. %g with tol = %e\n", - object_name(o), dim,olap,olap0,tol); +static const char *object_name(geometric_object o) { + switch (o.which_subclass) { + case CYLINDER: + switch (o.subclass.cylinder_data->which_subclass) { + case WEDGE: return "wedge"; + case CONE: return "cone"; + case CYLINDER_SELF: return "cylinder"; + } + case SPHERE: return "sphere"; + case BLOCK: + switch (o.subclass.block_data->which_subclass) { + case ELLIPSOID: return "ellipsoid"; + case BLOCK_SELF: return "block"; + } + case PRISM: return "prism"; + case COMPOUND_GEOMETRIC_OBJECT: return "compound object"; + default: return "geometric object"; + } +} + +void check_overlap(double tol, double olap0, double olap, int dim, geometric_object o, geom_box b) { + if (fabs(olap0 - olap) > 2 * tol * fabs(olap)) { + fprintf(stderr, + "Large error %e in overlap (%g vs. %g) for:\n" + " lattice = (%g,%g,%g), (%g,%g,%g), (%g,%g,%g)\n" + " box = (%g,%g,%g) - (%g,%g,%g)\n", + fabs(olap0 - olap) / fabs(olap), olap, olap0, geometry_lattice.basis1.x, + geometry_lattice.basis1.y, geometry_lattice.basis1.z, geometry_lattice.basis2.x, + geometry_lattice.basis2.y, geometry_lattice.basis2.z, geometry_lattice.basis3.x, + geometry_lattice.basis3.y, geometry_lattice.basis3.z, b.low.x, b.low.y, b.low.z, + b.high.x, b.high.y, b.high.z); + display_geometric_object_info(2, o); + /* exit(1); */ + } + else + printf("Got %s %dd overlap %g vs. %g with tol = %e\n", object_name(o), dim, olap, olap0, tol); } static void test_overlap(double tol, - number (*box_overlap_with_object) - (geom_box b, geometric_object o, - number tol, integer maxeval), - double (*simple_overlap) - (geom_box b, geometric_object o, double tol)) -{ - geometric_object o = random_object_and_lattice(); - vector3 dir = random_unit_vector3(); - geom_box b; - double d, olap, olap0; - int dim; - - b.low = make_vector3(myurand(-1,0), myurand(-1,0), myurand(-1,0)); - b.high = make_vector3(myurand(0,1), myurand(0,1), myurand(0,1)); - d = find_edge(o, dir, 10, tol); - b.low = vector3_plus(b.low, vector3_scale(d, dir)); - b.high = vector3_plus(b.high, vector3_scale(d, dir)); - - dim = rand() % 3 + 1; - if (dim < 3) - b.low.z = b.high.z = 0; - if (dim < 2) - b.low.y = b.high.y = 0; - - olap = box_overlap_with_object(b, o, tol/100, 10000/tol); - olap0 = simple_overlap(b, o, tol/2); - check_overlap(tol, olap0, olap, dim, o, b); - geometric_object_destroy(o); -} - -static void test_volume(double tol) -{ - geometric_object o = random_object_and_lattice(); - geom_box b; - double olap1, olap2; - - geom_get_bounding_box(o, &b); - olap1 = box_overlap_with_object(b, o, tol/100, 10000/tol); - b.low.x += 1e-7 * (b.high.x - b.low.x); /* b no longer contains o */ - olap2 = box_overlap_with_object(b, o, tol/100, 10000/tol); - check_overlap(tol, olap1, olap2, 3, o, b); - geometric_object_destroy(o); + number (*box_overlap_with_object)(geom_box b, geometric_object o, + number tol, integer maxeval), + double (*simple_overlap)(geom_box b, geometric_object o, double tol)) { + geometric_object o = random_object_and_lattice(); + vector3 dir = random_unit_vector3(); + geom_box b; + double d, olap, olap0; + int dim; + + b.low = make_vector3(myurand(-1, 0), myurand(-1, 0), myurand(-1, 0)); + b.high = make_vector3(myurand(0, 1), myurand(0, 1), myurand(0, 1)); + d = find_edge(o, dir, 10, tol); + b.low = vector3_plus(b.low, vector3_scale(d, dir)); + b.high = vector3_plus(b.high, vector3_scale(d, dir)); + + dim = rand() % 3 + 1; + if (dim < 3) b.low.z = b.high.z = 0; + if (dim < 2) b.low.y = b.high.y = 0; + + olap = box_overlap_with_object(b, o, tol / 100, 10000 / tol); + olap0 = simple_overlap(b, o, tol / 2); + check_overlap(tol, olap0, olap, dim, o, b); + geometric_object_destroy(o); +} + +static void test_volume(double tol) { + geometric_object o = random_object_and_lattice(); + geom_box b; + double olap1, olap2; + + geom_get_bounding_box(o, &b); + olap1 = box_overlap_with_object(b, o, tol / 100, 10000 / tol); + b.low.x += 1e-7 * (b.high.x - b.low.x); /* b no longer contains o */ + olap2 = box_overlap_with_object(b, o, tol / 100, 10000 / tol); + check_overlap(tol, olap1, olap2, 3, o, b); + geometric_object_destroy(o); } - /************************************************************************/ -int main(void) -{ - const int ntest = 100; - const double tol = 1e-2; - int i; - - srand(time(NULL)); - - geom_initialize(); - - printf("**** whole box overlap: ****\n"); - for (i = 0; i < ntest; ++i) - test_volume(tol); - for (i = 0; i < ntest; ++i) { - printf("**** box overlap: ****\n"); - test_overlap(tol, - box_overlap_with_object, - simple_overlap); - printf("**** ellipsoid overlap: ****\n"); - test_overlap(tol, - ellipsoid_overlap_with_object, - simple_ellip_overlap); - } +int main(void) { + const int ntest = 100; + const double tol = 1e-2; + int i; + + srand(time(NULL)); + + geom_initialize(); + + printf("**** whole box overlap: ****\n"); + for (i = 0; i < ntest; ++i) + test_volume(tol); + for (i = 0; i < ntest; ++i) { + printf("**** box overlap: ****\n"); + test_overlap(tol, box_overlap_with_object, simple_overlap); + printf("**** ellipsoid overlap: ****\n"); + test_overlap(tol, ellipsoid_overlap_with_object, simple_ellip_overlap); + } - return 0; + return 0; } - diff -Nru libctl-4.4.0/utils/Makefile.am libctl-4.5.0/utils/Makefile.am --- libctl-4.4.0/utils/Makefile.am 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/Makefile.am 2020-02-19 18:34:33.000000000 +0000 @@ -42,6 +42,11 @@ ctlgeom-types.h: ctl-io.h sed 's,SCM,void*,;s,ctl\.h,ctl-math.h,' ctl-io.h > $@ + echo '#ifndef LIBCTL_MAJOR_VERSION' >> $@ + echo '# define LIBCTL_MAJOR_VERSION '$(LIBCTL_MAJOR_VERSION) >> $@ + echo '# define LIBCTL_MINOR_VERSION '$(LIBCTL_MINOR_VERSION) >> $@ + echo '# define LIBCTL_BUGFIX_VERSION '$(LIBCTL_BUGFIX_VERSION) >> $@ + echo '#endif' >> $@ geom-ctl-io.c: ctl-io.c sed 's,ctl-io\.h,ctlgeom-types.h,;s,/.* Input variables .*/,@#include "geom-ctl-io-defaults.c"@#if 0@,;s,/.* Output variables .*/,#endif@,' ctl-io.c | tr '@' '\n' > $@ diff -Nru libctl-4.4.0/utils/nlopt.c libctl-4.5.0/utils/nlopt.c --- libctl-4.4.0/utils/nlopt.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/nlopt.c 2020-02-19 18:34:33.000000000 +0000 @@ -9,22 +9,21 @@ #include #include -static double f_scm_wrap(integer n, const double *x, double *grad, void *f_scm_p) -{ - SCM *f_scm = (SCM *) f_scm_p; - SCM ret = gh_call1(*f_scm, make_number_list(n, x)); - if (scm_real_p(ret)) - return scm_to_double(ret); - else { /* otherwise must be a list of value, gradient components, - i.e. (cons value gradient). */ - SCM gscm = ret; - int i; - for (i = 0; i < n; ++i) { - gscm = SCM_CDR(gscm); - grad[i] = scm_to_double(SCM_CAR(gscm)); - } - return scm_to_double(SCM_CAR(ret)); - } +static double f_scm_wrap(integer n, const double *x, double *grad, void *f_scm_p) { + SCM *f_scm = (SCM *)f_scm_p; + SCM ret = gh_call1(*f_scm, make_number_list(n, x)); + if (scm_real_p(ret)) + return scm_to_double(ret); + else { /* otherwise must be a list of value, gradient components, + i.e. (cons value gradient). */ + SCM gscm = ret; + int i; + for (i = 0; i < n; ++i) { + gscm = SCM_CDR(gscm); + grad[i] = scm_to_double(SCM_CAR(gscm)); + } + return scm_to_double(SCM_CAR(ret)); + } } /* Scheme-callable wrapper for nlopt_minimize() function. @@ -41,74 +40,73 @@ SCM maxeval_scm, SCM maxtime_scm */) { - nlopt_algorithm algorithm = (nlopt_algorithm) scm_to_int(algorithm_scm); - int i, n = list_length(x_scm); - double *x, *lb, *ub, *xtol_abs = 0; - double minf_max = scm_to_double(minf_max_scm); - double ftol_rel = scm_to_double(ftol_rel_scm); - double ftol_abs = scm_to_double(ftol_abs_scm); - double xtol_rel = 0; - double maxeval = 0; - double maxtime = 0; - int nrest = list_length(rest); -/* - double xtol_rel = scm_to_double(xtol_rel_scm); - int maxeval = scm_to_int(maxeval_scm); - double maxtime = scm_to_double(maxtime_scm); -*/ - double minf; - nlopt_result result; - SCM v, ret; - - x = (double *) malloc(sizeof(double) * n * 4); - lb = x + n; ub = lb + n; - if (!x) { - fprintf(stderr, "nlopt_minimize_scm: out of memory!\n"); - exit(EXIT_FAILURE); - } - if (list_length(lb_scm) != n || list_length(ub_scm) != n) { - fprintf(stderr, "nlopt_minimize_scm: invalid arguments\n"); - exit(EXIT_FAILURE); - } - - for (v=x_scm, i=0; i < n; ++i) { - x[i] = scm_to_double(SCM_CAR(v)); - v = SCM_CDR(v); - } - for (v=lb_scm, i=0; i < n; ++i) { - lb[i] = scm_to_double(SCM_CAR(v)); - v = SCM_CDR(v); - } - for (v=ub_scm, i=0; i < n; ++i) { - ub[i] = scm_to_double(SCM_CAR(v)); - v = SCM_CDR(v); - } - - if (nrest >= 1) xtol_rel = scm_to_double(SCM_CAR(rest)); - if (nrest >= 2) { - SCM xtol_abs_scm = scm_cadr(rest); - if (list_length(xtol_abs_scm)) { - xtol_abs = ub + n; - for (v=xtol_abs_scm, i=0; i < n; ++i) { - xtol_abs[i] = scm_to_double(SCM_CAR(v)); - v = SCM_CDR(v); - } - } - } - if (nrest >= 3) maxeval = scm_to_int(scm_caddr(rest)); - if (nrest >= 4) maxtime = scm_to_double(scm_cadddr(rest)); - - result = nlopt_minimize(algorithm, n, f_scm_wrap, &f_scm, - lb, ub, x, &minf, - minf_max, ftol_rel, ftol_abs, xtol_rel, xtol_abs, - maxeval, maxtime); + nlopt_algorithm algorithm = (nlopt_algorithm)scm_to_int(algorithm_scm); + int i, n = list_length(x_scm); + double *x, *lb, *ub, *xtol_abs = 0; + double minf_max = scm_to_double(minf_max_scm); + double ftol_rel = scm_to_double(ftol_rel_scm); + double ftol_abs = scm_to_double(ftol_abs_scm); + double xtol_rel = 0; + double maxeval = 0; + double maxtime = 0; + int nrest = list_length(rest); + /* + double xtol_rel = scm_to_double(xtol_rel_scm); + int maxeval = scm_to_int(maxeval_scm); + double maxtime = scm_to_double(maxtime_scm); + */ + double minf; + nlopt_result result; + SCM v, ret; + + x = (double *)malloc(sizeof(double) * n * 4); + lb = x + n; + ub = lb + n; + if (!x) { + fprintf(stderr, "nlopt_minimize_scm: out of memory!\n"); + exit(EXIT_FAILURE); + } + if (list_length(lb_scm) != n || list_length(ub_scm) != n) { + fprintf(stderr, "nlopt_minimize_scm: invalid arguments\n"); + exit(EXIT_FAILURE); + } + + for (v = x_scm, i = 0; i < n; ++i) { + x[i] = scm_to_double(SCM_CAR(v)); + v = SCM_CDR(v); + } + for (v = lb_scm, i = 0; i < n; ++i) { + lb[i] = scm_to_double(SCM_CAR(v)); + v = SCM_CDR(v); + } + for (v = ub_scm, i = 0; i < n; ++i) { + ub[i] = scm_to_double(SCM_CAR(v)); + v = SCM_CDR(v); + } + + if (nrest >= 1) xtol_rel = scm_to_double(SCM_CAR(rest)); + if (nrest >= 2) { + SCM xtol_abs_scm = scm_cadr(rest); + if (list_length(xtol_abs_scm)) { + xtol_abs = ub + n; + for (v = xtol_abs_scm, i = 0; i < n; ++i) { + xtol_abs[i] = scm_to_double(SCM_CAR(v)); + v = SCM_CDR(v); + } + } + } + if (nrest >= 3) maxeval = scm_to_int(scm_caddr(rest)); + if (nrest >= 4) maxtime = scm_to_double(scm_cadddr(rest)); + + result = nlopt_minimize(algorithm, n, f_scm_wrap, &f_scm, lb, ub, x, &minf, minf_max, ftol_rel, + ftol_abs, xtol_rel, xtol_abs, maxeval, maxtime); - ret = scm_cons(scm_from_int((int) result), - scm_cons(scm_from_double(minf), make_number_list(n, x))); + ret = + scm_cons(scm_from_int((int)result), scm_cons(scm_from_double(minf), make_number_list(n, x))); - free(x); + free(x); - return ret; + return ret; } #endif /* HAVE_NLOPT */ diff -Nru libctl-4.4.0/utils/test-prism.c libctl-4.5.0/utils/test-prism.c --- libctl-4.4.0/utils/test-prism.c 2019-11-13 03:28:06.000000000 +0000 +++ libctl-4.5.0/utils/test-prism.c 2020-02-19 18:34:33.000000000 +0000 @@ -1,5 +1,5 @@ /* libctl: flexible Guile-based control files for scientific software - * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson + * Copyright (C) 1998-2020 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -48,143 +48,136 @@ /* utility routines for writing points, lines, quadrilaterals */ /* to text files for viewing in e.g. gnuplot */ /***************************************************************/ -void GPPoint(FILE *f, vector3 v, prism *prsm) -{ if (prsm) - v = prism_coordinate_p2c(prsm, v); - fprintf(f,"%e %e %e \n\n\n",v.x,v.y,v.z); } - -void GPLine(FILE *f, vector3 v, vector3 l, prism *prsm) -{ if (prsm) - { v = prism_coordinate_p2c(prsm, v); - l = prism_vector_p2c(prsm, l); - } - fprintf(f,"%e %e %e \n",v.x,v.y,v.z); - fprintf(f,"%e %e %e \n\n\n",v.x+l.x,v.y+l.y,v.z+l.z); -} - -void GPQuad(FILE *f, vector3 v, vector3 l1, vector3 l2, prism *prsm) -{ - if (prsm) - { v = prism_coordinate_p2c(prsm, v); - l1 = prism_vector_p2c(prsm, l1); - l2 = prism_vector_p2c(prsm, l2); - } - fprintf(f,"%e %e %e \n",v.x,v.y,v.z); - fprintf(f,"%e %e %e \n",v.x+l1.x,v.y+l1.y,v.z+l1.z); - fprintf(f,"%e %e %e \n",v.x+l1.x+l2.x,v.y+l1.y+l2.y,v.z+l1.z+l2.z); - fprintf(f,"%e %e %e \n",v.x+l2.x,v.y+l2.y,v.z+l2.z); - fprintf(f,"%e %e %e \n\n\n",v.x,v.y,v.z); +void GPPoint(FILE *f, vector3 v, prism *prsm) { + if (prsm) v = prism_coordinate_p2c(prsm, v); + fprintf(f, "%e %e %e \n\n\n", v.x, v.y, v.z); +} + +void GPLine(FILE *f, vector3 v, vector3 l, prism *prsm) { + if (prsm) { + v = prism_coordinate_p2c(prsm, v); + l = prism_vector_p2c(prsm, l); + } + fprintf(f, "%e %e %e \n", v.x, v.y, v.z); + fprintf(f, "%e %e %e \n\n\n", v.x + l.x, v.y + l.y, v.z + l.z); +} + +void GPQuad(FILE *f, vector3 v, vector3 l1, vector3 l2, prism *prsm) { + if (prsm) { + v = prism_coordinate_p2c(prsm, v); + l1 = prism_vector_p2c(prsm, l1); + l2 = prism_vector_p2c(prsm, l2); + } + fprintf(f, "%e %e %e \n", v.x, v.y, v.z); + fprintf(f, "%e %e %e \n", v.x + l1.x, v.y + l1.y, v.z + l1.z); + fprintf(f, "%e %e %e \n", v.x + l1.x + l2.x, v.y + l1.y + l2.y, v.z + l1.z + l2.z); + fprintf(f, "%e %e %e \n", v.x + l2.x, v.y + l2.y, v.z + l2.z); + fprintf(f, "%e %e %e \n\n\n", v.x, v.y, v.z); } /***************************************************************/ /***************************************************************/ /***************************************************************/ -void my_get_prism_bounding_box(prism *prsm, geom_box *box) -{ +void my_get_prism_bounding_box(prism *prsm, geom_box *box) { vector3 *vertices = prsm->vertices_p.items; - int num_vertices = prsm->vertices_p.num_items; - double height = prsm->height; + int num_vertices = prsm->vertices_p.num_items; + double height = prsm->height; box->low = box->high = prism_coordinate_p2c(prsm, vertices[0]); int nv, fc; - for(nv=0; nvlow.x = fmin(box->low.x, vc.x); - box->low.y = fmin(box->low.y, vc.y); - box->low.z = fmin(box->low.z, vc.z); - - box->high.x = fmax(box->high.x, vc.x); - box->high.y = fmax(box->high.y, vc.y); - box->high.z = fmax(box->high.z, vc.z); - } + for (nv = 0; nv < num_vertices; nv++) + for (fc = 0; fc < 2; fc++) // 'floor,ceiling' + { + vector3 vp = vertices[nv]; + if (fc == 1) vp.z = height; + vector3 vc = prism_coordinate_p2c(prsm, vp); + + box->low.x = fmin(box->low.x, vc.x); + box->low.y = fmin(box->low.y, vc.y); + box->low.z = fmin(box->low.z, vc.z); + + box->high.x = fmax(box->high.x, vc.x); + box->high.y = fmax(box->high.y, vc.y); + box->high.z = fmax(box->high.z, vc.z); + } } -static vector3 make_vector3(double x, double y, double z) -{ +static vector3 make_vector3(double x, double y, double z) { vector3 v; - v.x = x; v.y = y; v.z = z; + v.x = x; + v.y = y; + v.z = z; return v; } /************************************************************************/ /* return a uniform random number in [a,b] */ /************************************************************************/ -static double urand(double a, double b) -{ return a + (b-a)*(rand()/((double)RAND_MAX)); } +static double urand(double a, double b) { return a + (b - a) * (rand() / ((double)RAND_MAX)); } -static double drand() -{ return urand(0.0,1.0); } +static double drand() { return urand(0.0, 1.0); } /************************************************************************/ /* random point uniformly distributed over a parallelepiped */ /************************************************************************/ -vector3 random_point_in_box(vector3 min_corner, vector3 max_corner) -{ - return make_vector3( urand(min_corner.x, max_corner.x), - urand(min_corner.y, max_corner.y), - urand(min_corner.z, max_corner.z) - ); +vector3 random_point_in_box(vector3 min_corner, vector3 max_corner) { + return make_vector3(urand(min_corner.x, max_corner.x), urand(min_corner.y, max_corner.y), + urand(min_corner.z, max_corner.z)); } /************************************************************************/ /* random point uniformly distributed over a planar polygon */ /* (all z coordinates are 0) */ /************************************************************************/ -vector3 random_point_in_polygon(vector3 *vertices, int num_vertices) -{ - // randomly choose a vertex and generate random point within the triangle +vector3 random_point_in_polygon(prism *prsm) { + // randomly choose a vertex and generate random point within the triangle // formed by that vertex, the next vertex, and the centroid + vector3 *vertices = prsm->vertices.items; + int num_vertices = prsm->vertices.num_items; int which_vertex = rand() % num_vertices; - vector3 v0 = {0,0,0}; + vector3 v0 = {0, 0, 0}; vector3 v1 = vertices[which_vertex]; - vector3 v2 = vertices[(which_vertex+1)%num_vertices]; - double xi = urand(0.0,1.0), eta = urand(0.0,1.0-xi); - return vector3_plus( vector3_scale(xi, vector3_minus(v1,v0)), - vector3_scale(eta, vector3_minus(v2,v0)) - ); + vector3 v2 = vertices[(which_vertex + 1) % num_vertices]; + double xi = urand(0.0, 1.0), eta = urand(0.0, 1.0 - xi); + return vector3_plus(vector3_scale(xi, vector3_minus(v1, v0)), + vector3_scale(eta, vector3_minus(v2, v0))); } - /************************************************************************/ /* random point uniformly distributed over the surface of a prism */ /************************************************************************/ -vector3 random_point_on_prism(geometric_object o) -{ - prism *prsm = o.subclass.prism_data; +vector3 random_point_on_prism(geometric_object o) { + prism *prsm = o.subclass.prism_data; vector3 *vertices = prsm->vertices_p.items; - int num_vertices = prsm->vertices_p.num_items; - double height = prsm->height; + int num_vertices = prsm->vertices_p.num_items; + double height = prsm->height; // choose a face - int num_faces = num_vertices + 2; - int which_face = rand() % num_faces; - if ( which_face < num_vertices ) // side face - { vector3 min_corner = vertices[which_face]; - vector3 max_corner = vertices[ (which_face+1)%num_vertices ]; - max_corner.z = height; - return random_point_in_box( prism_coordinate_p2c(prsm, min_corner), - prism_coordinate_p2c(prsm, max_corner) ); - } + int num_faces = num_vertices + 2; + int which_face = rand() % num_faces; + if (which_face < num_vertices) // side face + { + vector3 min_corner = vertices[which_face]; + vector3 max_corner = vertices[(which_face + 1) % num_vertices]; + max_corner.z = height; + return random_point_in_box(prism_coordinate_p2c(prsm, min_corner), + prism_coordinate_p2c(prsm, max_corner)); + } else // floor or ceiling - { - vector3 p = random_point_in_polygon(vertices, num_vertices); - if (which_face==num_faces-1) p.z=height; - return prism_coordinate_p2c(prsm, p); - } + { + vector3 p = random_point_in_polygon(prsm); + if (which_face == num_faces - 1) p.z = height; + return prism_coordinate_p2c(prsm, p); + } } /************************************************************************/ /* random unit vector with direction uniformly distributed over unit sphere*/ /************************************************************************/ -vector3 random_unit_vector3() -{ - double cos_theta=urand(0.0,1.0), sin_theta=sqrt(1.0-cos_theta*cos_theta); - double phi=urand(0.0,2.0*K_PI); - return make_vector3(sin_theta*cos(phi), sin_theta*sin(phi), cos_theta); +vector3 random_unit_vector3() { + double cos_theta = urand(0.0, 1.0), sin_theta = sqrt(1.0 - cos_theta * cos_theta); + double phi = urand(0.0, 2.0 * K_PI); + return make_vector3(sin_theta * cos(phi), sin_theta * sin(phi), cos_theta); } /***************************************************************/ @@ -193,410 +186,1120 @@ /* the prism may be plotted in gnuplot like this: */ /* gnuplot> splot 'MyFile' u 1:2:3 w lp pt 7 ps 1 */ /***************************************************************/ -void prism2gnuplot(prism *prsm, char *filename) -{ - vector3 *vertices = prsm->vertices_p.items; - int num_vertices = prsm->vertices_p.num_items; - double height = prsm->height; - - FILE *f=fopen(filename,"w"); +void prism2gnuplot(prism *prsm, char *filename) { + int num_vertices = prsm->vertices_p.num_items; + double height = prsm->height; + vector3_list vertices; + vertices.num_items = num_vertices; + vertices.items = (vector3 *)malloc(num_vertices * sizeof(vector3)); + memcpy(vertices.items, prsm->vertices_p.items, num_vertices * sizeof(vector3)); + vector3_list vertices_top; + vertices_top.num_items = num_vertices; + vertices_top.items = (vector3 *)malloc(num_vertices * sizeof(vector3)); int nv; - for(nv=0; nvvertices_p.items[nv], prsm->top_polygon_diff_vectors_p.items[nv]); + } + + FILE *f = fopen(filename, "w"); + for (nv = 0; nv < num_vertices; nv++) { + vector3 vap = vertices.items[nv]; + vap.z = 0.0; + vector3 vbp = vertices_top.items[nv]; + vbp.z = height; + vector3 vcp = vertices_top.items[(nv + 1) % num_vertices]; + vcp.z = height; + vector3 vdp = vertices.items[(nv + 1) % num_vertices]; + vdp.z = 0.0; + vector3 vac = prism_coordinate_p2c(prsm, vap); + vector3 vbc = prism_coordinate_p2c(prsm, vbp); + vector3 vcc = prism_coordinate_p2c(prsm, vcp); + vector3 vdc = prism_coordinate_p2c(prsm, vdp); + + fprintf(f, "%0.16e %0.16e %0.16e \n", vac.x, vac.y, vac.z); + fprintf(f, "%0.16e %0.16e %0.16e \n", vbc.x, vbc.y, vbc.z); + fprintf(f, "%0.16e %0.16e %0.16e \n", vcc.x, vcc.y, vcc.z); + fprintf(f, "%0.16e %0.16e %0.16e \n", vdc.x, vdc.y, vdc.z); + fprintf(f, "%0.16e %0.16e %0.16e \n", vac.x, vac.y, vac.z); + fprintf(f, "\n\n"); + } fclose(f); } /***************************************************************/ /* write prism vertices and edges to GMSH geometry (.geo) file */ /***************************************************************/ -void prism2gmsh(prism *prsm, char *filename) -{ +void prism2gmsh(prism *prsm, char *filename) { vector3 *vertices = prsm->vertices_p.items; - int num_vertices = prsm->vertices_p.num_items; - double height = prsm->height; - vector3 zhat = prsm->m_p2c.c2; - vector3 axis = vector3_scale(height, zhat); + int num_vertices = prsm->vertices_p.num_items; + double height = prsm->height; + vector3 zhat = prsm->m_p2c.c2; + vector3 axis = vector3_scale(height, zhat); - FILE *f=fopen(filename,"w"); + FILE *f = fopen(filename, "w"); int nv; - for(nv=0; nv=0.0 ? 1.0 : -1.0; } +double sgn(double x) { return x >= 0.0 ? 1.0 : -1.0; } -vector3 standardize(vector3 v) -{ vector3 sv=unit_vector3(v); - double sign = (sv.z!=0.0 ? sgn(sv.z) : sv.y!=0.0 ? sgn(sv.y) : sgn(sv.x)); - return vector3_scale(sign,sv); +vector3 standardize(vector3 v) { + vector3 sv = unit_vector3(v); + double sign = (sv.z != 0.0 ? sgn(sv.z) : sv.y != 0.0 ? sgn(sv.y) : sgn(sv.x)); + return vector3_scale(sign, sv); } /************************************************************************/ -/* first unit test: check inclusion of randomly-generated points */ +/* 1st unit test: check inclusion of randomly-generated points */ /************************************************************************/ -int test_point_inclusion(geometric_object the_block, geometric_object the_prism, - int num_tests, int write_log) -{ +int test_point_inclusion(geometric_object the_block, geometric_object the_prism, int num_tests, + int write_log) { vector3 size = the_block.subclass.block_data->size; vector3 min_corner = vector3_scale(-1.0, size); vector3 max_corner = vector3_scale(+1.0, size); - FILE *f = write_log ? fopen("/tmp/test-prism.points","w") : 0; - int num_failed=0, num_adjusted=0, n; - for(n=0; nsize; vector3 min_corner = vector3_scale(-1.0, size); vector3 max_corner = vector3_scale(+1.0, size); - FILE *f = write_log ? fopen("/tmp/test-prism.normals","w") : 0; + FILE *f = write_log ? fopen("/tmp/test-prism.normals", "w") : 0; - int num_failed=0; - double tolerance=1.0e-6; + int num_failed = 0; + double tolerance = 1.0e-6; int n; - for(n=0; nsize; vector3 min_corner = vector3_scale(-1.0, size); vector3 max_corner = vector3_scale(+1.0, size); - FILE *f = write_log ? fopen("/tmp/test-prism.segments","w") : 0; + FILE *f = write_log ? fopen("/tmp/test-prism.segments", "w") : 0; - int num_failed=0; + int num_failed = 0; int n; - for(n=0; n 1.0e-6*fmax(fabs(sblock),fabs(sprism)) ) - num_failed++; - - if (f) - { - int success = fabs(sblock-sprism) <= 1.0e-6*fmax(fabs(sblock),fabs(sprism)); - fprintf(f," %e %e %s\n",sblock,sprism,success ? "success" : "fail"); - if (success==0) - { fprintf(f,"#%e %e %e %e %e %e %e %e\n",p.x,p.y,p.z,d.x,d.y,d.z,a,b); - fprintf(f,"%e %e %e\n%e %e %e\n%e %e %e\n", - p.x,p.y,p.z, - p.x+a*d.x,p.y+a*d.y,p.z+a*d.z, - p.x+b*d.x,p.y+b*d.y,p.z+b*d.z); - } - fprintf(f,"\n"); + for (n = 0; n < num_tests; n++) { + // randomly generated base point within enlarged bounding box + vector3 p = random_point_in_box(min_corner, max_corner); + vector3 d = random_unit_vector3(); + double a = urand(0.0, 1.0); + double b = urand(0.0, 1.0); + + double sblock = intersect_line_segment_with_object(p, d, the_block, a, b); + double sprism = intersect_line_segment_with_object(p, d, the_prism, a, b); + if (fabs(sblock - sprism) > 1.0e-6 * fmax(fabs(sblock), fabs(sprism))) num_failed++; + + if (f) { + int success = fabs(sblock - sprism) <= 1.0e-6 * fmax(fabs(sblock), fabs(sprism)); + fprintf(f, " %e %e %s\n", sblock, sprism, success ? "success" : "fail"); + if (success == 0) { + fprintf(f, "#%e %e %e %e %e %e %e %e\n", p.x, p.y, p.z, d.x, d.y, d.z, a, b); + fprintf(f, "%e %e %e\n%e %e %e\n%e %e %e\n", p.x, p.y, p.z, p.x + a * d.x, p.y + a * d.y, + p.z + a * d.z, p.x + b * d.x, p.y + b * d.y, p.z + b * d.z); } - } + fprintf(f, "\n"); + } + } if (f) fclose(f); - - printf("%i/%i segments failed\n",num_failed,num_tests); + + printf("%i/%i segments failed\n", num_failed, num_tests); + return num_failed; +} + +/************************************************************************/ +/* 4th unit test: check of point in polygon test with slanted H */ +/************************************************************************/ +int test_point_in_polygon(int write_log) { + // make array of test points that should always pass + vector3 pass[5]; + pass[0] = make_vector3(0.3, 0.5, 0.0); + pass[1] = make_vector3(0.4, 0.4, 0.0); + pass[2] = make_vector3(0.5, 0.7, 0.0); + pass[3] = make_vector3(0.5, 0.5, 0.0); + pass[4] = make_vector3(0.5, 0.3, 0.0); + + // make array of test points that should always pass + vector3 fail[5]; + fail[0] = make_vector3(0.2, 0.2, 0.0); + fail[1] = make_vector3(0.3, 0.3, 0.0); + fail[2] = make_vector3(0.4, 0.6, 0.0); + fail[3] = make_vector3(0.6, 0.4, 0.0); + fail[4] = make_vector3(0.7, 0.7, 0.0); + + // make array of nodes for the test polygon (an H slanted by 45 degrees) + int num_nodes = 12; + vector3 nodes[num_nodes]; + nodes[0] = make_vector3(0.5, 0.2, 0.0); + nodes[1] = make_vector3(0.6, 0.3, 0.0); + nodes[2] = make_vector3(0.5, 0.4, 0.0); + nodes[3] = make_vector3(0.6, 0.5, 0.0); + nodes[4] = make_vector3(0.7, 0.4, 0.0); + nodes[5] = make_vector3(0.8, 0.5, 0.0); + nodes[6] = make_vector3(0.5, 0.8, 0.0); + nodes[7] = make_vector3(0.4, 0.7, 0.0); + nodes[8] = make_vector3(0.5, 0.6, 0.0); + nodes[9] = make_vector3(0.4, 0.5, 0.0); + nodes[10] = make_vector3(0.3, 0.6, 0.0); + nodes[11] = make_vector3(0.2, 0.5, 0.0); + + FILE *f = write_log ? fopen("/tmp/test-prism.point-in-polygon", "w") : 0; + + boolean all_points_success = 1; + boolean include_boundaries = 1; + int i; + for (i = 0; i < 5; i++) { + boolean local_success = node_in_or_on_polygon(pass[i], nodes, num_nodes, include_boundaries); + if (!local_success) { + all_points_success = 0; + } + if (f) { + fprintf(f, "%f %f %i\n", pass[i].x, pass[i].y, local_success); + } + } + for (i = 0; i < 5; i++) { + boolean local_success = !node_in_or_on_polygon(fail[i], nodes, num_nodes, include_boundaries); + if (!local_success) { + all_points_success = 0; + } + if (f) { + fprintf(f, "%f %f %i\n", pass[i].x, pass[i].y, local_success); + } + } + + if (f) { + if (all_points_success) { + printf("all test points for slanted H pass\n"); + } + else { + printf("one or more test points for slanted H fail\n"); + } + fclose(f); + } + + int num_failed; + if (all_points_success) { + num_failed = 0; + printf("all test points for slanted H pass\n"); + } + else { + num_failed = 1; + printf("one or more test points for slanted H fail\n"); + } + return num_failed; } +/************************************************************************/ +/* 5th unit test: saves a prism with a square base with a normal */ +/* sidewall angle and a prism with the same base polygon with non- */ +/* normal sidewall angle to separate GNU plot files. */ +/************************************************************************/ +int test_square_base_sidewall_prisms_to_gnuplot() { + void *m = NULL; + + int num_nodes_square = 4; + vector3 nodes_square[num_nodes_square]; + nodes_square[0] = make_vector3(-10.0, -10.0, 0.0); + nodes_square[1] = make_vector3(-10.0, 10.0, 0.0); + nodes_square[2] = make_vector3(10.0, 10.0, 0.0); + nodes_square[3] = make_vector3(10.0, -10.0, 0.0); + + double height_square = 100; + vector3 zhat = make_vector3(0, 0, 1); + + double normal_sidewall = 0; + geometric_object square_normal_sidewall_geom_object = make_prism(m, nodes_square, num_nodes_square, height_square, zhat); + prism *square_normal_sidewall_prism = square_normal_sidewall_geom_object.subclass.prism_data; + + double one_degree_sidewall = 1.0 * 2 * K_PI / 360.0; + geometric_object square_one_degree_sidewall_geom_object = make_slanted_prism(m, nodes_square, num_nodes_square, height_square, zhat, one_degree_sidewall); + prism *square_one_degree_sidewall_prism = square_one_degree_sidewall_geom_object.subclass.prism_data; + + prism2gnuplot(square_normal_sidewall_prism, "square_normal_sidewall_gnu_plot.dat"); + prism2gnuplot(square_one_degree_sidewall_prism, "square_one_degree_sidewall_gnu_plot.dat"); + + return 0; +} + +/************************************************************************/ +/* 6th unit test: saves a prism with a concave octagonal c-shaped */ +/* base with a normal sidewall angle and a prism with the same base */ +/* polygon with non-normal sidewall angle to separate GNU plot files. */ +/************************************************************************/ +int test_octagon_c_base_sidewall_prisms_to_gnuplot() { + void *m = NULL; + + int num_nodes_octagon_c = 16; + vector3 nodes_octagon_c[num_nodes_octagon_c]; + nodes_octagon_c[0] = make_vector3(114.905, 88.7434, 0.0); + nodes_octagon_c[1] = make_vector3(88.7434, 114.905, 0.0); + nodes_octagon_c[2] = make_vector3(51.7447, 114.905, 0.0); + nodes_octagon_c[3] = make_vector3(25.5827, 88.7434, 0.0); + nodes_octagon_c[4] = make_vector3(25.5827, 51.7447, 0.0); + nodes_octagon_c[5] = make_vector3(51.7447, 25.5827, 0.0); + nodes_octagon_c[6] = make_vector3(88.7434, 25.5827, 0.0); + nodes_octagon_c[7] = make_vector3(114.905, 51.7447, 0.0); + nodes_octagon_c[8] = make_vector3(140.488, 41.1477, 0.0); + nodes_octagon_c[9] = make_vector3(99.3401, 0.0, 0.0); + nodes_octagon_c[10] = make_vector3(41.1477, 0.0, 0.0); + nodes_octagon_c[11] = make_vector3(0.0, 41.1477, 0.0); + nodes_octagon_c[12] = make_vector3(0.0, 99.3401, 0.0); + nodes_octagon_c[13] = make_vector3(41.1477, 140.488, 0.0); + nodes_octagon_c[14] = make_vector3(99.3401, 140.488, 0.0); + nodes_octagon_c[15] = make_vector3(140.488, 99.3401, 0.0); + + double height_octagon_c = 127; + vector3 zhat = make_vector3(0, 0, 1); + + double normal_sidewall = 0; + geometric_object octagon_c_normal_sidewall_geom_object = make_prism(m, nodes_octagon_c, num_nodes_octagon_c, height_octagon_c, zhat); + prism *octagon_c_normal_sidewall_prism = octagon_c_normal_sidewall_geom_object.subclass.prism_data; + + double two_half_degree_sidewall = 2.5 * 2 * K_PI / 360.0; + geometric_object octagon_c_two_half_degree_sidewall_geom_object = make_slanted_prism(m, nodes_octagon_c, num_nodes_octagon_c, height_octagon_c, zhat, two_half_degree_sidewall); + prism *octagon_c_two_half_degree_sidewall_prism = octagon_c_two_half_degree_sidewall_geom_object.subclass.prism_data; + + prism2gnuplot(octagon_c_normal_sidewall_prism, "octagon_c_normal_sidewall_gnu_plot.dat"); + prism2gnuplot(octagon_c_two_half_degree_sidewall_prism, "octagon_c_two_half_degree_sidewall_gnu_plot.dat"); + + return 0; +} + +/************************************************************************/ +/* 7th unit test: test all of geom.c's prism helper functions on a */ +/* prism with a concave octagonal c-shaped base with both a normal */ +/* sidewall angle a 2.5-degree sidewall angle. */ +/************************************************************************/ +double relative_error(double actual, double expected) { + return fabs((actual-expected)/actual); +} + +int test_helper_functions_on_octagonal_c_prism() { + int i; + double tolerance = 5.0e-5; + + void *m = NULL; + + int num_nodes_octagon_c = 16; + vector3 nodes_octagon_c[num_nodes_octagon_c]; + nodes_octagon_c[0] = make_vector3(114.905, 88.7434, 0.0); + nodes_octagon_c[1] = make_vector3(88.7434, 114.905, 0.0); + nodes_octagon_c[2] = make_vector3(51.7447, 114.905, 0.0); + nodes_octagon_c[3] = make_vector3(25.5827, 88.7434, 0.0); + nodes_octagon_c[4] = make_vector3(25.5827, 51.7447, 0.0); + nodes_octagon_c[5] = make_vector3(51.7447, 25.5827, 0.0); + nodes_octagon_c[6] = make_vector3(88.7434, 25.5827, 0.0); + nodes_octagon_c[7] = make_vector3(114.905, 51.7447, 0.0); + nodes_octagon_c[8] = make_vector3(140.488, 41.1477, 0.0); + nodes_octagon_c[9] = make_vector3(99.3401, 0.0, 0.0); + nodes_octagon_c[10] = make_vector3(41.1477, 0.0, 0.0); + nodes_octagon_c[11] = make_vector3(0.0, 41.1477, 0.0); + nodes_octagon_c[12] = make_vector3(0.0, 99.3401, 0.0); + nodes_octagon_c[13] = make_vector3(41.1477, 140.488, 0.0); + nodes_octagon_c[14] = make_vector3(99.3401, 140.488, 0.0); + nodes_octagon_c[15] = make_vector3(140.488, 99.3401, 0.0); + + double height_octagon_c = 127; + vector3 zhat = make_vector3(0, 0, 1); + + double normal_sidewall = 0; + geometric_object octagon_c_normal_sidewall_geom_object = make_prism(m, nodes_octagon_c, num_nodes_octagon_c, height_octagon_c, zhat); + prism *octagon_c_normal_sidewall_prism = octagon_c_normal_sidewall_geom_object.subclass.prism_data; + + double two_half_degree_sidewall = 2.5 * 2 * K_PI / 360.0; + geometric_object octagon_c_two_half_degree_sidewall_geom_object = make_slanted_prism(m, nodes_octagon_c, num_nodes_octagon_c, height_octagon_c, zhat, two_half_degree_sidewall); + prism *octagon_c_two_half_degree_sidewall_prism = octagon_c_two_half_degree_sidewall_geom_object.subclass.prism_data; + + int num_tests_normal = 0; + int num_failed_normal = 0; + int num_tests_tapered = 0; + int num_failed_tapered = 0; + + printf("prism helper function testing:\n"); + + // test geom_object_volume + double volume_normal_sidewall_freecad = 1082462.27453587; + double volume_normal_sidewall_calculated = geom_object_volume(octagon_c_normal_sidewall_geom_object); + num_tests_normal++; + if (relative_error(volume_normal_sidewall_calculated, volume_normal_sidewall_freecad) > tolerance) { + num_failed_normal++; + } + + double volume_tapered_sidewall_freecad = 833978.754046812; + double volume_tapered_sidewall_calculated = geom_object_volume(octagon_c_two_half_degree_sidewall_geom_object); + num_tests_tapered++; + if (relative_error(volume_tapered_sidewall_calculated, volume_tapered_sidewall_freecad) > tolerance) { + num_failed_tapered++; + } + + // test point_in_prism + vector3_list point_in_prism_test_points_normal_sidewall; + point_in_prism_test_points_normal_sidewall.num_items = 25; + point_in_prism_test_points_normal_sidewall.items = (vector3 *)malloc(point_in_prism_test_points_normal_sidewall.num_items * sizeof(vector3)); + point_in_prism_test_points_normal_sidewall.items[0] = make_vector3(46.4462, 12.7914, 63.5000); // interior point + point_in_prism_test_points_normal_sidewall.items[1] = make_vector3(127.697, 46.4462, 95.2500); // interior point + point_in_prism_test_points_normal_sidewall.items[2] = make_vector3(70.2439, 0.00000, 31.7500); // point on external side face + point_in_prism_test_points_normal_sidewall.items[3] = make_vector3(101.824, 38.6637, 95.2500); // point on internal side face + point_in_prism_test_points_normal_sidewall.items[4] = make_vector3(19.1870, 49.0955, 127.000); // point on top face + point_in_prism_test_points_normal_sidewall.items[5] = make_vector3(134.092, 96.6909, 0.00000); // point on bottom face + point_in_prism_test_points_normal_sidewall.items[6] = make_vector3(127.6965, 94.04175, 127.0); // edge on top + point_in_prism_test_points_normal_sidewall.items[7] = make_vector3(70.24405, 114.905, 0.0000); // edge on bottom + point_in_prism_test_points_normal_sidewall.items[8] = make_vector3(41.1477, 0.00000, 100.000); // edge on side + point_in_prism_test_points_normal_sidewall.items[9] = make_vector3(140.488, 99.3401, 127.000); // vertex -> corner on top at edge of c + point_in_prism_test_points_normal_sidewall.items[10] = make_vector3(140.488, 99.3401, 129.000); // continuation of edge from vertex + point_in_prism_test_points_normal_sidewall.items[11] = make_vector3(141.902, 97.9259, 127.000); // continuation of edge from vertex + point_in_prism_test_points_normal_sidewall.items[12] = make_vector3(142.336, 100.105, 127.000); // continuation of edge from vertex + point_in_prism_test_points_normal_sidewall.items[13] = make_vector3(137.226, 99.9890, 125.000); // continuation of edge from vertex + point_in_prism_test_points_normal_sidewall.items[14] = make_vector3(25.5827, 88.7434, 127.000); // vertex -> corner on top inside c + point_in_prism_test_points_normal_sidewall.items[15] = make_vector3(25.5827, 88.7434, 129.000); // continuation of edge from vertex + point_in_prism_test_points_normal_sidewall.items[16] = make_vector3(24.1685, 87.3292, 127.000); // continuation of edge from vertex + point_in_prism_test_points_normal_sidewall.items[17] = make_vector3(25.5827, 90.7434, 127.000); // continuation of edge from vertex + point_in_prism_test_points_normal_sidewall.items[18] = make_vector3(26.9969, 88.1576, 125.000); // continuation of edge from vertex + point_in_prism_test_points_normal_sidewall.items[19] = make_vector3(41.1477, 0.00000, 127.000); // vertex -> corner on top outside c + point_in_prism_test_points_normal_sidewall.items[20] = make_vector3(114.905, 51.7447, 0.00000); // vertex -> corner on bottom at edge of c + point_in_prism_test_points_normal_sidewall.items[21] = make_vector3(51.7447, 114.905, 0.00000); // vertex -> corner on bottom inside c + point_in_prism_test_points_normal_sidewall.items[22] = make_vector3(0.00000, 99.3401, 0.00000); // vertex -> corner on bottom outside c + point_in_prism_test_points_normal_sidewall.items[23] = make_vector3(0.00000, 0.00000, 0.00000); // origin + point_in_prism_test_points_normal_sidewall.items[24] = make_vector3(70.2440, 70.2440, 63.5000); // center of the c + + int point_in_prism_expected_normal_sidewall[point_in_prism_test_points_normal_sidewall.num_items]; + point_in_prism_expected_normal_sidewall[0] = 1; // interior point + point_in_prism_expected_normal_sidewall[1] = 1; // interior point + point_in_prism_expected_normal_sidewall[2] = 1; // point on external side face + point_in_prism_expected_normal_sidewall[3] = 1; // point on internal side face + point_in_prism_expected_normal_sidewall[4] = 1; // point on top face + point_in_prism_expected_normal_sidewall[5] = 1; // point on bottom face + point_in_prism_expected_normal_sidewall[6] = 1; // edge on top + point_in_prism_expected_normal_sidewall[7] = 1; // edge on bottom + point_in_prism_expected_normal_sidewall[8] = 1; // edge on side + point_in_prism_expected_normal_sidewall[9] = 1; // vertex -> corner on top at edge of c + point_in_prism_expected_normal_sidewall[10] = 0; // continuation of edge from vertex + point_in_prism_expected_normal_sidewall[11] = 0; // continuation of edge from vertex + point_in_prism_expected_normal_sidewall[12] = 0; // continuation of edge from vertex + point_in_prism_expected_normal_sidewall[13] = 1; // continuation of edge from vertex + point_in_prism_expected_normal_sidewall[14] = 1; // vertex -> corner on top inside c + point_in_prism_expected_normal_sidewall[15] = 0; // continuation of edge from vertex + point_in_prism_expected_normal_sidewall[16] = 1; // continuation of edge from vertex + point_in_prism_expected_normal_sidewall[17] = 1; // continuation of edge from vertex + point_in_prism_expected_normal_sidewall[18] = 0; // continuation of edge from vertex + point_in_prism_expected_normal_sidewall[19] = 1; // vertex -> corner on top outside c + point_in_prism_expected_normal_sidewall[20] = 1; // vertex -> corner on bottom at edge of c + point_in_prism_expected_normal_sidewall[21] = 1; // vertex -> corner on bottom inside c + point_in_prism_expected_normal_sidewall[22] = 1; // vertex -> corner on bottom outside c + point_in_prism_expected_normal_sidewall[23] = 0; // origin + point_in_prism_expected_normal_sidewall[24] = 0; // center of the c + + int point_in_prism_actual_normal_sidewall[point_in_prism_test_points_normal_sidewall.num_items]; + for (i = 0; i < point_in_prism_test_points_normal_sidewall.num_items; i++) { + num_tests_normal++; + point_in_prism_actual_normal_sidewall[i] = point_in_fixed_pobjectp(point_in_prism_test_points_normal_sidewall.items[i], &octagon_c_normal_sidewall_geom_object); + } + + for (i = 0; i < point_in_prism_test_points_normal_sidewall.num_items; i++) { + if (point_in_prism_actual_normal_sidewall[i] != point_in_prism_expected_normal_sidewall[i]) { + ctl_printf("\tAt (%f, %f, %f) we expected point_in_fixed_pobjectp on the normal sidewall prism to return %i, but instead it returned %i\n", point_in_prism_test_points_normal_sidewall.items[i].x, point_in_prism_test_points_normal_sidewall.items[i].y, point_in_prism_test_points_normal_sidewall.items[i].z, point_in_prism_expected_normal_sidewall[i], point_in_prism_actual_normal_sidewall[i]); + num_failed_normal++; + } + } + + vector3_list point_in_prism_test_points_tapered_sidewall; + point_in_prism_test_points_tapered_sidewall.num_items = 25; + point_in_prism_test_points_tapered_sidewall.items = (vector3 *)malloc(point_in_prism_test_points_tapered_sidewall.num_items * sizeof(vector3)); + point_in_prism_test_points_tapered_sidewall.items[0] = make_vector3(46.446200000000005, 12.791350000000001, 63.500000000000000); // interior point + point_in_prism_test_points_tapered_sidewall.items[1] = make_vector3(123.45257948434455, 98.285670515655440, 63.500000000000000); // interior point + point_in_prism_test_points_tapered_sidewall.items[2] = make_vector3(102.72366312425248, 35.642282404302410, 63.500000000000000); // point on external side face + point_in_prism_test_points_tapered_sidewall.items[3] = make_vector3(21.423995187964220, 70.244056207821420, 95.250000000000000); // point on internal side face + point_in_prism_test_points_tapered_sidewall.items[4] = make_vector3(29.618783181268217, 110.86913318128589, 127.00000000000000); // point on top face + point_in_prism_test_points_tapered_sidewall.items[5] = make_vector3(134.09200000000000, 96.690900000000000, 0.0000000000000000); // point on bottom face + point_in_prism_test_points_tapered_sidewall.items[6] = make_vector3(20.037760250618970, 70.244062415642820, 127.00000000000000); // edge on top + point_in_prism_test_points_tapered_sidewall.items[7] = make_vector3(70.244050000000000, 114.90500000000000, 0.0000000000000000); // edge on bottom + point_in_prism_test_points_tapered_sidewall.items[8] = make_vector3(50.596305376632360, 22.810230125309488, 63.500000000000000); // edge on side + point_in_prism_test_points_tapered_sidewall.items[9] = make_vector3(130.69912049055401, 101.28725051332967, 127.00000000000000); // vertex -> corner on top at edge of c // failing + point_in_prism_test_points_tapered_sidewall.items[10] = make_vector3(130.62227962053330, 101.30253528002449, 127.99692620419043); // continuation of edge from vertex + point_in_prism_test_points_tapered_sidewall.items[11] = make_vector3(131.40622727174056, 100.58014373214311, 127.00000000000000); // continuation of edge from vertex + point_in_prism_test_points_tapered_sidewall.items[12] = make_vector3(131.62300162627434, 101.66993007518276, 127.00000000000000); // continuation of edge from vertex + point_in_prism_test_points_tapered_sidewall.items[13] = make_vector3(129.14497344366782, 101.59639296596830, 126.00307379580957); // continuation of edge from vertex + point_in_prism_test_points_tapered_sidewall.items[14] = make_vector3(20.037760250618966, 91.040214078020940, 127.00000000000000); // vertex -> corner on top inside c + point_in_prism_test_points_tapered_sidewall.items[15] = make_vector3(19.994147981293120, 91.058279066765540, 127.99888519167415); // continuation of edge from vertex + point_in_prism_test_points_tapered_sidewall.items[16] = make_vector3(19.330648063809882, 90.333112702498250, 127.00000000000000); // continuation of edge from vertex + point_in_prism_test_points_tapered_sidewall.items[17] = make_vector3(20.037760250618966, 92.040214078020940, 127.00000000000000); // continuation of edge from vertex + point_in_prism_test_points_tapered_sidewall.items[18] = make_vector3(20.788484706753895, 90.729250464799020, 126.00111480832585); // continuation of edge from vertex + point_in_prism_test_points_tapered_sidewall.items[19] = make_vector3(43.444489246735300, 5.5449397493810295, 127.00000000000000); // vertex -> corner on top outside c + point_in_prism_test_points_tapered_sidewall.items[20] = make_vector3(114.90500000000000, 51.744700000000000, 0.0000000000000000); // vertex -> corner on bottom at edge of c + point_in_prism_test_points_tapered_sidewall.items[21] = make_vector3(51.744700000000000, 114.90500000000000, 0.0000000000000000); // vertex -> corner on bottom inside c + point_in_prism_test_points_tapered_sidewall.items[22] = make_vector3(0.0000000000000000, 99.340100000000000, 0.0000000000000000); // vertex -> corner on bottom outside c + point_in_prism_test_points_tapered_sidewall.items[23] = make_vector3(0.0000000000000000, 0.0000000000000000, 0.0000000000000000); // origin + point_in_prism_test_points_tapered_sidewall.items[24] = make_vector3(70.244000000000000, 70.244000000000000, 63.500000000000000); // center of the c + + int point_in_prism_expected_tapered_sidewall[point_in_prism_test_points_tapered_sidewall.num_items]; + point_in_prism_expected_tapered_sidewall[0] = 1; // interior point + point_in_prism_expected_tapered_sidewall[1] = 1; // interior point + point_in_prism_expected_tapered_sidewall[2] = 1; // point on external side face + point_in_prism_expected_tapered_sidewall[3] = 1; // point on internal side face + point_in_prism_expected_tapered_sidewall[4] = 1; // point on top face + point_in_prism_expected_tapered_sidewall[5] = 1; // point on bottom face + point_in_prism_expected_tapered_sidewall[6] = 1; // edge on top + point_in_prism_expected_tapered_sidewall[7] = 1; // edge on bottom + point_in_prism_expected_tapered_sidewall[8] = 1; // edge on side + point_in_prism_expected_tapered_sidewall[9] = 1; // vertex -> corner on top at edge of c + point_in_prism_expected_tapered_sidewall[10] = 0; // continuation of edge from vertex + point_in_prism_expected_tapered_sidewall[11] = 0; // continuation of edge from vertex + point_in_prism_expected_tapered_sidewall[12] = 0; // continuation of edge from vertex + point_in_prism_expected_tapered_sidewall[13] = 1; // continuation of edge from vertex + point_in_prism_expected_tapered_sidewall[14] = 1; // vertex -> corner on top inside c + point_in_prism_expected_tapered_sidewall[15] = 0; // continuation of edge from vertex + point_in_prism_expected_tapered_sidewall[16] = 1; // continuation of edge from vertex + point_in_prism_expected_tapered_sidewall[17] = 1; // continuation of edge from vertex + point_in_prism_expected_tapered_sidewall[18] = 0; // continuation of edge from vertex + point_in_prism_expected_tapered_sidewall[19] = 1; // vertex -> corner on top outside c + point_in_prism_expected_tapered_sidewall[20] = 1; // vertex -> corner on bottom at edge of c + point_in_prism_expected_tapered_sidewall[21] = 1; // vertex -> corner on bottom inside c + point_in_prism_expected_tapered_sidewall[22] = 1; // vertex -> corner on bottom outside c + point_in_prism_expected_tapered_sidewall[23] = 0; // origin + point_in_prism_expected_tapered_sidewall[24] = 0; // center of the c + + int point_in_prism_actual_tapered_sidewall[point_in_prism_test_points_tapered_sidewall.num_items]; + for (i = 0; i < point_in_prism_test_points_tapered_sidewall.num_items; i++) { + num_tests_tapered++; + point_in_prism_actual_tapered_sidewall[i] = point_in_fixed_pobjectp(point_in_prism_test_points_tapered_sidewall.items[i], &octagon_c_two_half_degree_sidewall_geom_object); + } + + for (i = 0; i < point_in_prism_test_points_tapered_sidewall.num_items; i++) { + if (point_in_prism_actual_tapered_sidewall[i] != point_in_prism_expected_tapered_sidewall[i]) { + ctl_printf("\tAt (%f, %f, %f) we expected point_in_fixed_pobjectp on the tapered sidewall prism to return %i, but instead it returned %i\n", point_in_prism_test_points_tapered_sidewall.items[i].x, point_in_prism_test_points_tapered_sidewall.items[i].y, point_in_prism_test_points_tapered_sidewall.items[i].z, point_in_prism_expected_tapered_sidewall[i], point_in_prism_actual_tapered_sidewall[i]); + num_failed_tapered++; + } + } + + // test normal_to_prism + vector3_list normal_to_prism_test_points_normal_sidewall; + normal_to_prism_test_points_normal_sidewall.num_items = 30; + normal_to_prism_test_points_normal_sidewall.items = (vector3 *)malloc(normal_to_prism_test_points_normal_sidewall.num_items * sizeof(vector3)); + normal_to_prism_test_points_normal_sidewall.items[0] = make_vector3(98.2887, 98.2887, 63.5000); // points around sidewalls + normal_to_prism_test_points_normal_sidewall.items[1] = make_vector3(70.2441, 109.905, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[2] = make_vector3(42.1992, 98.2886, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[3] = make_vector3(30.5827, 70.2441, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[4] = make_vector3(42.1992, 42.1992, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[5] = make_vector3(70.2441, 30.5827, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[6] = make_vector3(98.2886, 42.1992, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[7] = make_vector3(129.610, 51.0656, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[8] = make_vector3(123.450, 17.0383, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[9] = make_vector3(70.2439, -5.0000, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[10] = make_vector3(17.0383, 17.0383, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[11] = make_vector3(-5.0000, 70.2439, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[12] = make_vector3(17.0383, 123.450, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[13] = make_vector3(70.2439, 145.488, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[14] = make_vector3(123.450, 123.450, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[15] = make_vector3(129.610, 89.4223, 63.5000); + normal_to_prism_test_points_normal_sidewall.items[16] = make_vector3(110.869, 110.869, -5.0000); // points off bottom face + normal_to_prism_test_points_normal_sidewall.items[17] = make_vector3(70.2440, 127.697, -5.0000); + normal_to_prism_test_points_normal_sidewall.items[18] = make_vector3(29.6188, 110.869, -5.0000); + normal_to_prism_test_points_normal_sidewall.items[19] = make_vector3(12.7914, 70.2440, -5.0000); + normal_to_prism_test_points_normal_sidewall.items[20] = make_vector3(29.6188, 29.6188, -5.0000); + normal_to_prism_test_points_normal_sidewall.items[21] = make_vector3(70.2440, 12.7914, -5.0000); + normal_to_prism_test_points_normal_sidewall.items[22] = make_vector3(110.869, 29.6188, -5.0000); + normal_to_prism_test_points_normal_sidewall.items[23] = make_vector3(108.747, 112.991, 132.000); // points off top face + normal_to_prism_test_points_normal_sidewall.items[24] = make_vector3(70.2440, 127.697, 132.000); + normal_to_prism_test_points_normal_sidewall.items[25] = make_vector3(29.6188, 110.869, 132.000); + normal_to_prism_test_points_normal_sidewall.items[26] = make_vector3(12.7914, 70.2440, 132.000); + normal_to_prism_test_points_normal_sidewall.items[27] = make_vector3(29.6188, 29.6188, 132.000); + normal_to_prism_test_points_normal_sidewall.items[28] = make_vector3(70.2440, 12.7914, 132.000); + normal_to_prism_test_points_normal_sidewall.items[29] = make_vector3(108.747, 27.4968, 132.000); + + vector3 normal_to_prism_expected_normal_sidewall[normal_to_prism_test_points_normal_sidewall.num_items]; + normal_to_prism_expected_normal_sidewall[0] = make_vector3(-0.707107, -0.707107, 0.0000000); // points around sidewalls + normal_to_prism_expected_normal_sidewall[1] = make_vector3(0.0000000, -1.000000, 0.0000000); + normal_to_prism_expected_normal_sidewall[2] = make_vector3(0.7071010, -0.707112, 0.0000000); + normal_to_prism_expected_normal_sidewall[3] = make_vector3(1.0000000, 0.0000000, 0.0000000); + normal_to_prism_expected_normal_sidewall[4] = make_vector3(0.7071070, 0.7071070, 0.0000000); + normal_to_prism_expected_normal_sidewall[5] = make_vector3(0.0000000, 1.0000000, 0.0000000); + normal_to_prism_expected_normal_sidewall[6] = make_vector3(-0.707112, 0.7071010, 0.0000000); + normal_to_prism_expected_normal_sidewall[7] = make_vector3(0.3826890, 0.9238770, 0.0000000); + normal_to_prism_expected_normal_sidewall[8] = make_vector3(0.7071050, -0.707108, 0.0000000); + normal_to_prism_expected_normal_sidewall[9] = make_vector3(0.0000000, -1.000000, 0.0000000); + normal_to_prism_expected_normal_sidewall[10] = make_vector3(-0.707107, -0.707107, 0.0000000); + normal_to_prism_expected_normal_sidewall[11] = make_vector3(-1.000000, 0.0000000, 0.0000000); + normal_to_prism_expected_normal_sidewall[12] = make_vector3(-0.707108, 0.7071050, 0.0000000); + normal_to_prism_expected_normal_sidewall[13] = make_vector3(0.0000000, 1.0000000, 0.0000000); + normal_to_prism_expected_normal_sidewall[14] = make_vector3(0.7071070, 0.7071070, 0.0000000); + normal_to_prism_expected_normal_sidewall[15] = make_vector3(0.3826800, -0.923881, 0.0000000); + normal_to_prism_expected_normal_sidewall[16] = make_vector3(0.0000000, 0.0000000, -1.000000); // points off bottom face + normal_to_prism_expected_normal_sidewall[17] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_normal_sidewall[18] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_normal_sidewall[19] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_normal_sidewall[20] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_normal_sidewall[21] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_normal_sidewall[22] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_normal_sidewall[23] = make_vector3(0.0000000, 0.0000000, 1.0000000); // points off top face + normal_to_prism_expected_normal_sidewall[24] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_normal_sidewall[25] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_normal_sidewall[26] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_normal_sidewall[27] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_normal_sidewall[28] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_normal_sidewall[29] = make_vector3(0.0000000, 0.0000000, 1.0000000); + + vector3 normal_to_prism_actual_normal_sidewall[normal_to_prism_test_points_normal_sidewall.num_items]; + for (i = 0; i < normal_to_prism_test_points_normal_sidewall.num_items; i++) { + num_tests_normal++; + normal_to_prism_actual_normal_sidewall[i] = unit_vector3(normal_to_object(normal_to_prism_test_points_normal_sidewall.items[i], octagon_c_normal_sidewall_geom_object)); + } + + for (i = 0; i < normal_to_prism_test_points_normal_sidewall.num_items; i++) { + if (!vector3_nearly_equal(normal_to_prism_expected_normal_sidewall[i], normal_to_prism_actual_normal_sidewall[i], tolerance) + && !vector3_nearly_equal(normal_to_prism_expected_normal_sidewall[i], vector3_scale(-1, normal_to_prism_actual_normal_sidewall[i]), tolerance)) { + num_failed_normal++; + vector3 test_point = normal_to_prism_test_points_normal_sidewall.items[i]; + vector3 expected = normal_to_prism_expected_normal_sidewall[i]; + vector3 actual = normal_to_prism_actual_normal_sidewall[i]; + ctl_printf("\tAt (%f, %f, %f) the expected normal vector was (%f, %f, %f), but the actual\n\t\tnormal vector was (%f, %f, %f\n", test_point.x, test_point.y, test_point.z, expected.x, expected.y, expected.z, actual.x, actual.y, actual.z); + } + } + + vector3_list normal_to_prism_test_points_tapered_sidewall; + normal_to_prism_test_points_tapered_sidewall.num_items = 30; + normal_to_prism_test_points_tapered_sidewall.items = (vector3 *)malloc(normal_to_prism_test_points_tapered_sidewall.num_items * sizeof(vector3)); + normal_to_prism_test_points_tapered_sidewall.items[0] = make_vector3(106.256, 108.378, 63.2819); // points around sidewalls + normal_to_prism_test_points_tapered_sidewall.items[1] = make_vector3(70.2441, 122.673, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[2] = make_vector3(33.1711, 107.317, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[3] = make_vector3(17.8150, 70.2441, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[4] = make_vector3(33.1711, 33.1711, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[5] = make_vector3(70.2441, 17.8150, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[6] = make_vector3(106.256, 32.1101, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[7] = make_vector3(123.663, 39.7093, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[8] = make_vector3(113.360, 25.0055, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[9] = make_vector3(70.2439, 7.76771, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[10] = make_vector3(26.0665, 26.0665, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[11] = make_vector3(7.76771, 70.2439, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[12] = make_vector3(26.0665, 114.421, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[13] = make_vector3(70.2439, 132.720, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[14] = make_vector3(113.360, 115.482, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[15] = make_vector3(123.663, 100.779, 63.2819); + normal_to_prism_test_points_tapered_sidewall.items[16] = make_vector3(110.869, 110.869, -5.0000); // points off bottom face + normal_to_prism_test_points_tapered_sidewall.items[17] = make_vector3(70.2440, 127.697, -5.0000); + normal_to_prism_test_points_tapered_sidewall.items[18] = make_vector3(29.6188, 110.869, -5.0000); + normal_to_prism_test_points_tapered_sidewall.items[19] = make_vector3(12.7914, 70.2440, -5.0000); + normal_to_prism_test_points_tapered_sidewall.items[20] = make_vector3(29.6188, 29.6188, -5.0000); + normal_to_prism_test_points_tapered_sidewall.items[21] = make_vector3(70.2440, 12.7914, -5.0000); + normal_to_prism_test_points_tapered_sidewall.items[22] = make_vector3(110.869, 29.6188, -5.0000); + normal_to_prism_test_points_tapered_sidewall.items[23] = make_vector3(108.747, 112.991, 132.000); // points off top face + normal_to_prism_test_points_tapered_sidewall.items[24] = make_vector3(70.2440, 127.697, 132.000); + normal_to_prism_test_points_tapered_sidewall.items[25] = make_vector3(29.6188, 110.869, 132.000); + normal_to_prism_test_points_tapered_sidewall.items[26] = make_vector3(12.7914, 70.2440, 132.000); + normal_to_prism_test_points_tapered_sidewall.items[27] = make_vector3(29.6188, 29.6188, 132.000); + normal_to_prism_test_points_tapered_sidewall.items[28] = make_vector3(70.2440, 12.7914, 132.000); + normal_to_prism_test_points_tapered_sidewall.items[29] = make_vector3(108.747, 27.4968, 132.000); + + vector3 normal_to_prism_expected_tapered_sidewall[normal_to_prism_test_points_tapered_sidewall.num_items]; + normal_to_prism_expected_tapered_sidewall[0] = make_vector3(0.7064340, 0.7064340, -0.0436194); // points off top face + normal_to_prism_expected_tapered_sidewall[1] = make_vector3(0.0000000, 0.9990480, -0.0436194); + normal_to_prism_expected_tapered_sidewall[2] = make_vector3(-0.706428, 0.7064390, -0.0436194); + normal_to_prism_expected_tapered_sidewall[3] = make_vector3(-0.999048, 0.0000000, -0.0436194); + normal_to_prism_expected_tapered_sidewall[4] = make_vector3(-0.706434, -0.706434, -0.0436194); + normal_to_prism_expected_tapered_sidewall[5] = make_vector3(0.0000000, -0.999048, -0.0436194); + normal_to_prism_expected_tapered_sidewall[6] = make_vector3(0.7064390, -0.706428, -0.0436194); + normal_to_prism_expected_tapered_sidewall[7] = make_vector3(-0.382325, -0.922998, -0.0436194); + normal_to_prism_expected_tapered_sidewall[8] = make_vector3(-0.706432, 0.7064350, -0.0436194); + normal_to_prism_expected_tapered_sidewall[9] = make_vector3(0.0000000, 0.9990480, -0.0436194); + normal_to_prism_expected_tapered_sidewall[10] = make_vector3(0.7064340, 0.7064340, -0.0436194); + normal_to_prism_expected_tapered_sidewall[11] = make_vector3(0.9990480, 0.0000000, -0.0436194); + normal_to_prism_expected_tapered_sidewall[12] = make_vector3(0.7064350, -0.706432, -0.0436194); + normal_to_prism_expected_tapered_sidewall[13] = make_vector3(0.0000000, -0.999048, -0.0436194); + normal_to_prism_expected_tapered_sidewall[14] = make_vector3(-0.706434, -0.706434, -0.0436194); + normal_to_prism_expected_tapered_sidewall[15] = make_vector3(-0.382315, 0.9230020, -0.0436194); + normal_to_prism_expected_tapered_sidewall[16] = make_vector3(0.0000000, 0.0000000, -1.000000); // points off bottom face + normal_to_prism_expected_tapered_sidewall[17] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_tapered_sidewall[18] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_tapered_sidewall[19] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_tapered_sidewall[20] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_tapered_sidewall[21] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_tapered_sidewall[22] = make_vector3(0.0000000, 0.0000000, -1.000000); + normal_to_prism_expected_tapered_sidewall[23] = make_vector3(0.0000000, 0.0000000, 1.0000000); // points off top face + normal_to_prism_expected_tapered_sidewall[24] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_tapered_sidewall[25] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_tapered_sidewall[26] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_tapered_sidewall[27] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_tapered_sidewall[28] = make_vector3(0.0000000, 0.0000000, 1.0000000); + normal_to_prism_expected_tapered_sidewall[29] = make_vector3(0.0000000, 0.0000000, 1.0000000); + + vector3 normal_to_prism_actual_tapered_sidewall[normal_to_prism_test_points_tapered_sidewall.num_items]; + for (i = 0; i < normal_to_prism_test_points_tapered_sidewall.num_items; i++) { + num_tests_tapered++; + normal_to_prism_actual_tapered_sidewall[i] = unit_vector3(normal_to_object(normal_to_prism_test_points_tapered_sidewall.items[i], octagon_c_two_half_degree_sidewall_geom_object)); + } + + for (i = 0; i < normal_to_prism_test_points_tapered_sidewall.num_items; i++) { + if (!vector3_nearly_equal(normal_to_prism_expected_tapered_sidewall[i], normal_to_prism_actual_tapered_sidewall[i], tolerance) + && !vector3_nearly_equal(normal_to_prism_expected_tapered_sidewall[i], vector3_scale(-1, normal_to_prism_actual_tapered_sidewall[i]), tolerance)) { + num_failed_tapered++; + vector3 test_point = normal_to_prism_test_points_tapered_sidewall.items[i]; + vector3 expected = normal_to_prism_expected_tapered_sidewall[i]; + vector3 actual = normal_to_prism_actual_tapered_sidewall[i]; + ctl_printf("\tAt (%f, %f, %f) the expected normal vector was (%f, %f, %f), but the actual\n\t\tnormal vector was (%f, %f, %f\n", test_point.x, test_point.y, test_point.z, expected.x, expected.y, expected.z, actual.x, actual.y, actual.z); + } + } + + // test intersect_line_segment_with_prism + vector3_list intersect_line_with_prism_test_points_normal_sidewall; + intersect_line_with_prism_test_points_normal_sidewall.num_items = 9; + intersect_line_with_prism_test_points_normal_sidewall.items = (vector3 *)malloc(intersect_line_with_prism_test_points_normal_sidewall.num_items * sizeof(vector3)); + intersect_line_with_prism_test_points_normal_sidewall.items[0] = make_vector3(100.809, 144.033, 130.205); // line crossing top[15] to bottom[11] + intersect_line_with_prism_test_points_normal_sidewall.items[1] = make_vector3(17.0383, 123.450, 63.5000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_points_normal_sidewall.items[2] = make_vector3(17.0383, 123.450, 63.5000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_points_normal_sidewall.items[3] = make_vector3(17.0383, 123.450, 63.5000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_points_normal_sidewall.items[4] = make_vector3(12.7914, 70.2440, 63.5000); // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_test_points_normal_sidewall.items[5] = make_vector3(12.7914, 70.2440, 63.5000); // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_test_points_normal_sidewall.items[6] = make_vector3(40.1648, 142.861, 131.290); // between top point 14 and center of c on bottom + intersect_line_with_prism_test_points_normal_sidewall.items[7] = make_vector3(41.1477, 0.00000, 127.000); // between top point 11 and origin + intersect_line_with_prism_test_points_normal_sidewall.items[8] = make_vector3(51.7447, 114.905, 127.000); // between top point 3 and center of c on bottom + + vector3 intersect_line_with_prism_test_vectors_normal_sidewall[intersect_line_with_prism_test_points_normal_sidewall.num_items]; + intersect_line_with_prism_test_vectors_normal_sidewall[0] = make_vector3(-0.29372, -0.709099, -0.64102); // line crossing top[15] to bottom[11] + intersect_line_with_prism_test_vectors_normal_sidewall[1] = make_vector3(0.707107, -0.707107, 0.000000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_vectors_normal_sidewall[2] = make_vector3(0.707107, -0.707107, 0.000000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_vectors_normal_sidewall[3] = make_vector3(0.707107, -0.707107, 0.000000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_vectors_normal_sidewall[4] = make_vector3(1.000000, 0.0000000, 0.000000); // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_test_vectors_normal_sidewall[5] = make_vector3(-1.00000, 0.0000000, 0.000000); // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_test_vectors_normal_sidewall[6] = make_vector3(0.196571, -0.474559,-0.857994); // between top point 14 and center of c on bottom + intersect_line_with_prism_test_vectors_normal_sidewall[7] = make_vector3(-0.308223, 0.000000,-0.951314); // between top point 11 and origin + intersect_line_with_prism_test_vectors_normal_sidewall[8] = make_vector3(0.136135, -0.328658,-0.934586); // between top point 3 and center of c on bottom + + double intersect_line_with_prism_expected_normal_sidewall[intersect_line_with_prism_test_points_normal_sidewall.num_items]; + intersect_line_with_prism_expected_normal_sidewall[0] = 36.07816398; // line crossing top[15] to bottom[11] + intersect_line_with_prism_expected_normal_sidewall[1] = 25.58291121; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_expected_normal_sidewall[2] = 25.58291120; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_expected_normal_sidewall[3] = 51.16582241; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_expected_normal_sidewall[4] = 12.79135000; // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_expected_normal_sidewall[5] = 12.79135000; // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_expected_normal_sidewall[6] = 53.90914485; // between top point 14 and center of c on bottom + intersect_line_with_prism_expected_normal_sidewall[7] = 0.000000000; // between top point 11 and origin + intersect_line_with_prism_expected_normal_sidewall[8] = 0.000000000; // between top point 3 and center of c on bottom + + double intersect_line_with_prism_a_normal_sidewall[intersect_line_with_prism_test_points_normal_sidewall.num_items]; + intersect_line_with_prism_a_normal_sidewall[0] = 0; // line crossing top[15] to bottom[11] + intersect_line_with_prism_a_normal_sidewall[1] = 0; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_a_normal_sidewall[2] = 100; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_a_normal_sidewall[3] = 0; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_a_normal_sidewall[4] = 0; // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_a_normal_sidewall[5] = 0; // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_a_normal_sidewall[6] = 0; // between top point 14 and center of c on bottom + intersect_line_with_prism_a_normal_sidewall[7] = 0; // between top point 11 and origin + intersect_line_with_prism_a_normal_sidewall[8] = 0; // between top point 3 and center of c on bottom + + double intersect_line_with_prism_b_normal_sidewall[intersect_line_with_prism_test_points_normal_sidewall.num_items]; + intersect_line_with_prism_b_normal_sidewall[0] = 150; // line crossing top[15] to bottom[11] + intersect_line_with_prism_b_normal_sidewall[1] = 100; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_b_normal_sidewall[2] = 150; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_b_normal_sidewall[3] = 150; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_b_normal_sidewall[4] = 300; // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_b_normal_sidewall[5] = 300; // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_b_normal_sidewall[6] = 300; // between top point 14 and center of c on bottom + intersect_line_with_prism_b_normal_sidewall[7] = 300; // between top point 11 and origin + intersect_line_with_prism_b_normal_sidewall[8] = 300; // between top point 3 and center of c on bottom + + double intersect_line_with_prism_actual_normal_sidewall[intersect_line_with_prism_test_points_normal_sidewall.num_items]; + for (i = 0; i < intersect_line_with_prism_test_points_normal_sidewall.num_items; i++) { + num_tests_normal++; + vector3 p = intersect_line_with_prism_test_points_normal_sidewall.items[i]; + vector3 d = intersect_line_with_prism_test_vectors_normal_sidewall[i]; + geometric_object o = octagon_c_normal_sidewall_geom_object; + double a = intersect_line_with_prism_a_normal_sidewall[i]; + double b = intersect_line_with_prism_b_normal_sidewall[i]; + intersect_line_with_prism_actual_normal_sidewall[i] = intersect_line_segment_with_object(p, d, o, a, b); + } + + for (i = 0; i < intersect_line_with_prism_test_points_normal_sidewall.num_items; i++) { + double actual = intersect_line_with_prism_actual_normal_sidewall[i]; + double expected = intersect_line_with_prism_expected_normal_sidewall[i]; + if (fabs(fabs(actual)-fabs(expected)) > tolerance * fmax(fabs(actual), fabs(expected))) { + double px = intersect_line_with_prism_test_points_normal_sidewall.items[i].x; + double py = intersect_line_with_prism_test_points_normal_sidewall.items[i].y; + double pz = intersect_line_with_prism_test_points_normal_sidewall.items[i].z; + double dx = intersect_line_with_prism_test_vectors_normal_sidewall[i].x; + double dy = intersect_line_with_prism_test_vectors_normal_sidewall[i].y; + double dz = intersect_line_with_prism_test_vectors_normal_sidewall[i].z; + ctl_printf( + "\tThe line segment emanating from (%f, %f, %f) along s*d,\n\t\twith 0 <= s <= 300, d = (%f, %f, %f), was expected\n\t\tto have intersection length %f but instead had %f.\n", + px, py, pz, dx, dy, dz, expected, actual); + num_failed_normal++; + } + } + + vector3_list intersect_line_with_prism_test_points_tapered_sidewall; + intersect_line_with_prism_test_points_tapered_sidewall.num_items = 9; + intersect_line_with_prism_test_points_tapered_sidewall.items = (vector3 *)malloc(intersect_line_with_prism_test_points_tapered_sidewall.num_items * sizeof(vector3)); + intersect_line_with_prism_test_points_tapered_sidewall.items[0] = make_vector3(98.4872, 138.429, 130.281); // line crossing top[15] to bottom[11] + intersect_line_with_prism_test_points_tapered_sidewall.items[1] = make_vector3(19.0383, 121.528, 63.5000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_points_tapered_sidewall.items[2] = make_vector3(19.0383, 121.528, 63.5000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_points_tapered_sidewall.items[3] = make_vector3(19.0383, 121.528, 63.5000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_points_tapered_sidewall.items[4] = make_vector3(12.7914, 70.2440, 63.5000); // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_test_points_tapered_sidewall.items[5] = make_vector3(12.7914, 70.2440, 63.5000); // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_test_points_tapered_sidewall.items[6] = make_vector3(43.4445, 134.943, 127.000); // between top point 14 and center of c on bottom + intersect_line_with_prism_test_points_tapered_sidewall.items[7] = make_vector3(43.4445, 5.54494, 127.000); // between top point 11 and origin + intersect_line_with_prism_test_points_tapered_sidewall.items[8] = make_vector3(34.7428, 105.745, 127.000); // between top point 3 and center of c on bottom + + vector3 intersect_line_with_prism_test_vectors_tapered_sidewall[intersect_line_with_prism_test_points_tapered_sidewall.num_items]; + intersect_line_with_prism_test_vectors_tapered_sidewall[0] = make_vector3(-0.288786, -0.697187, -0.656149); // line crossing top[15] to bottom[11] + intersect_line_with_prism_test_vectors_tapered_sidewall[1] = make_vector3(0.6992010, -0.714925, 0.0000000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_vectors_tapered_sidewall[2] = make_vector3(0.6992010, -0.714925, 0.0000000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_vectors_tapered_sidewall[3] = make_vector3(0.6992010, -0.714925, 0.0000000); // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_test_vectors_tapered_sidewall[4] = make_vector3(1.0000000, 0.0000000, 0.0000000); // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_test_vectors_tapered_sidewall[5] = make_vector3(-1.000000, 0.0000000, 0.0000000); // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_test_vectors_tapered_sidewall[6] = make_vector3(0.1847880,-0.4461140, -0.875692); // between top point 14 and center of c on bottom + intersect_line_with_prism_test_vectors_tapered_sidewall[7] = make_vector3(-0.323393,-0.0412755, -0.945364); // between top point 11 and origin + intersect_line_with_prism_test_vectors_tapered_sidewall[8] = make_vector3(0.2599600,-0.2599600, -0.929969); // between top point 3 and center of c on bottom + + double intersect_line_with_prism_expected_tapered_sidewall[intersect_line_with_prism_test_points_tapered_sidewall.num_items]; + intersect_line_with_prism_expected_tapered_sidewall[0] = 21.67860775; // line crossing top[15] to bottom[11] + intersect_line_with_prism_expected_tapered_sidewall[1] = 20.03920840; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_expected_tapered_sidewall[2] = 20.03919670; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_expected_tapered_sidewall[3] = 40.07840510; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_expected_tapered_sidewall[4] = 10.01888013; // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_expected_tapered_sidewall[5] = 10.01888013; // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_expected_tapered_sidewall[6] = 35.53300107; // between top point 14 and center of c on bottom + intersect_line_with_prism_expected_tapered_sidewall[7] = 0.000000000; // between top point 11 and origin + intersect_line_with_prism_expected_tapered_sidewall[8] = 0.000000000; // between top point 3 and center of c on bottom + + double intersect_line_with_prism_a_tapered_sidewall[intersect_line_with_prism_test_points_tapered_sidewall.num_items]; + intersect_line_with_prism_a_tapered_sidewall[0] = 0; // line crossing top[15] to bottom[11] + intersect_line_with_prism_a_tapered_sidewall[1] = 0; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_a_tapered_sidewall[2] = 50; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_a_tapered_sidewall[3] = 0; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_a_tapered_sidewall[4] = 0; // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_a_tapered_sidewall[5] = 0; // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_a_tapered_sidewall[6] = 0; // between top point 14 and center of c on bottom + intersect_line_with_prism_a_tapered_sidewall[7] = 0; // between top point 11 and origin + intersect_line_with_prism_a_tapered_sidewall[8] = 0; // between top point 3 and center of c on bottom + + double intersect_line_with_prism_b_tapered_sidewall[intersect_line_with_prism_test_points_tapered_sidewall.num_items]; + intersect_line_with_prism_b_tapered_sidewall[0] = 150; // line crossing top[15] to bottom[11] + intersect_line_with_prism_b_tapered_sidewall[1] = 50; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_b_tapered_sidewall[2] = 150; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_b_tapered_sidewall[3] = 150; // line crossing midpoint 13-14 face to midpoint 9-10 face + intersect_line_with_prism_b_tapered_sidewall[4] = 300; // interior point between 4, 5, 12, 13 in positive xhat + intersect_line_with_prism_b_tapered_sidewall[5] = 300; // interior point between 4, 5, 12, 13 in negative xhat + intersect_line_with_prism_b_tapered_sidewall[6] = 300; // between top point 14 and center of c on bottom + intersect_line_with_prism_b_tapered_sidewall[7] = 300; // between top point 11 and origin + intersect_line_with_prism_b_tapered_sidewall[8] = 300; // between top point 3 and center of c on bottom + + double intersect_line_with_prism_actual_tapered_sidewall[intersect_line_with_prism_test_points_tapered_sidewall.num_items]; + for (i = 0; i < intersect_line_with_prism_test_points_tapered_sidewall.num_items; i++) { + num_tests_tapered++; + vector3 p = intersect_line_with_prism_test_points_tapered_sidewall.items[i]; + vector3 d = intersect_line_with_prism_test_vectors_tapered_sidewall[i]; + geometric_object o = octagon_c_two_half_degree_sidewall_geom_object; + double a = intersect_line_with_prism_a_tapered_sidewall[i]; + double b = intersect_line_with_prism_b_tapered_sidewall[i]; + intersect_line_with_prism_actual_tapered_sidewall[i] = intersect_line_segment_with_object(p, d, o, a, b); + } + + for (i = 0; i < intersect_line_with_prism_test_points_tapered_sidewall.num_items; i++) { + double actual = intersect_line_with_prism_actual_tapered_sidewall[i]; + double expected = intersect_line_with_prism_expected_tapered_sidewall[i]; + if (fabs(fabs(actual)-fabs(expected)) > tolerance * fmax(fabs(actual), fabs(expected))) { + double px = intersect_line_with_prism_test_points_tapered_sidewall.items[i].x; + double py = intersect_line_with_prism_test_points_tapered_sidewall.items[i].y; + double pz = intersect_line_with_prism_test_points_tapered_sidewall.items[i].z; + double dx = intersect_line_with_prism_test_vectors_tapered_sidewall[i].x; + double dy = intersect_line_with_prism_test_vectors_tapered_sidewall[i].y; + double dz = intersect_line_with_prism_test_vectors_tapered_sidewall[i].z; + ctl_printf( + "\tThe line segment emanating from (%f, %f, %f) along s*d,\n\t\twith 0 <= s <= 300, d = (%f, %f, %f), was expected\n\t\tto have intersection length %f but instead had %f.\n", + px, py, pz, dx, dy, dz, expected, actual); + num_failed_tapered++; + } + } + + printf("\tprism helper function testing summary: \n\t\t%i/%i tests failed with normal sidewall\n\t\t%i/%i tests failed with tapered sidewall\n", num_failed_normal, num_tests_normal, num_failed_tapered, num_tests_tapered); + + return num_failed_normal + num_failed_tapered; +} + /***************************************************************/ /* unit tests: create the same parallelepiped two ways (as a */ /* block and as a prism) and verify that geometric primitives */ /* give identical results */ /***************************************************************/ -#define NUMPTS 10000 +#define NUMPTS 10000 #define NUMLINES 1000 #define LX 0.5 #define LY 1.0 #define LZ 1.5 -int run_unit_tests() -{ - void* m = NULL; - vector3 c = { 0, 0, 0 }; - vector3 xhat = make_vector3(1,0,0); - vector3 yhat = make_vector3(0,1,0); - vector3 zhat = make_vector3(0,0,1); - vector3 size = make_vector3(LX,LY,LZ); - - vector3 v[4]; - v[0].x=-0.5*LX; v[0].y=-0.5*LY; v[0].z=-0.5*LZ; - v[1].x=+0.5*LX; v[1].y=-0.5*LY; v[1].z=-0.5*LZ; - v[2].x=+0.5*LX; v[2].y=+0.5*LY; v[2].z=-0.5*LZ; - v[3].x=-0.5*LX; v[3].y=+0.5*LY; v[3].z=-0.5*LZ; +int run_unit_tests() { + void *m = NULL; + vector3 c = {0, 0, 0}; + vector3 xhat = make_vector3(1, 0, 0); + vector3 yhat = make_vector3(0, 1, 0); + vector3 zhat = make_vector3(0, 0, 1); + vector3 size = make_vector3(LX, LY, LZ); + + vector3 v[4]; + v[0].x = -0.5 * LX; + v[0].y = -0.5 * LY; + v[0].z = -0.5 * LZ; + v[1].x = +0.5 * LX; + v[1].y = -0.5 * LY; + v[1].z = -0.5 * LZ; + v[2].x = +0.5 * LX; + v[2].y = +0.5 * LY; + v[2].z = -0.5 * LZ; + v[3].x = -0.5 * LX; + v[3].y = +0.5 * LY; + v[3].z = -0.5 * LZ; geometric_object the_block = make_block(m, c, xhat, yhat, zhat, size); - geometric_object the_prism=make_prism(m, v, 4, LZ, zhat); + geometric_object the_prism = make_prism(m, v, 4, LZ, zhat); /***************************************************************/ /* with probability P_SHIFT, shift the centers of both block */ /* and prism by a random displacement vector */ /***************************************************************/ #define P_SHIFT 0.75 - if ( urand(0.0,1.0) < P_SHIFT ) - { vector3 shift = vector3_scale( urand(0.0,1.0), random_unit_vector3() ); - the_block.center = vector3_plus(the_block.center, shift); - the_prism.center = vector3_plus(the_prism.center, shift); - } + if (urand(0.0, 1.0) < P_SHIFT) { + vector3 shift = vector3_scale(urand(0.0, 1.0), random_unit_vector3()); + the_block.center = vector3_plus(the_block.center, shift); + the_prism.center = vector3_plus(the_prism.center, shift); + } - char *s=getenv("LIBCTL_TEST_PRISM_LOG"); - int write_log = (s && s[0]=='1') ? 1 : 0; + char *s = getenv("LIBCTL_TEST_PRISM_LOG"); + int write_log = (s && s[0] == '1') ? 1 : 0; - if (write_log) - prism2gnuplot(the_prism.subclass.prism_data, "/tmp/test-prism.prism"); + if (write_log) prism2gnuplot(the_prism.subclass.prism_data, "/tmp/test-prism.prism"); int num_failed_1 = test_point_inclusion(the_block, the_prism, NUMPTS, write_log); // 20180712 disabling this test because the new implementation of normal_to_object // for prisms is actually more accurate than the implementation for blocks, // although the distinction is only significant in cases where it is irrelevant - int num_failed_2 = 0; // test_normal_to_object(the_block, the_prism, NUMLINES, write_log); + // int num_failed_2 = test_normal_to_object(the_block, the_prism, NUMLINES, write_log); int num_failed_3 = test_line_segment_intersection(the_block, the_prism, NUMLINES, write_log); + int num_failed_4 = test_point_in_polygon(write_log); + int num_failed_5 = test_square_base_sidewall_prisms_to_gnuplot(); + int num_failed_6 = test_octagon_c_base_sidewall_prisms_to_gnuplot(); + int num_failed_7 = test_helper_functions_on_octagonal_c_prism(); - return num_failed_1 + num_failed_2 + num_failed_3; + return num_failed_1 + num_failed_3 + num_failed_4 + num_failed_5 + num_failed_6 + num_failed_7; } /***************************************************************/ /***************************************************************/ /***************************************************************/ -void print_usage(char *msg, int print_usage) -{ - if (!msg) - fprintf(stderr,"%s\n",msg); - if (print_usage) - { printf("usage: \n"); - printf(" --vertexfile MyVertices\n"); - printf(" --height height\n"); - printf(" --axis x y z\n"); - printf("\n"); - printf(" --point x y z\n"); - printf(" --dir x y z\n"); - printf(" --a a\n"); - printf(" --b b\n"); - } +void print_usage(char *msg, int print_usage) { + if (!msg) fprintf(stderr, "%s\n", msg); + if (print_usage) { + printf("usage: \n"); + printf(" --vertexfile MyVertices\n"); + printf(" --height height\n"); + printf(" --axis x y z\n"); + printf("\n"); + printf(" --point x y z\n"); + printf(" --dir x y z\n"); + printf(" --a a\n"); + printf(" --b b\n"); + } exit(1); } -void quit(char *msg) -{ print_usage(msg, 0); } +void quit(char *msg) { print_usage(msg, 0); } -void usage(char *msg) -{ print_usage(msg, 1); } +void usage(char *msg) { print_usage(msg, 1); } /************************************************************************/ /************************************************************************/ /************************************************************************/ -int main(int argc, char *argv[]) -{ +int main(int argc, char *argv[]) { srand(time(NULL)); geom_initialize(); - if (argc<=1) // if no arguments, run unit tests - return run_unit_tests(); + if (argc <= 1) // if no arguments, run unit tests + return run_unit_tests(); /***************************************************************/ /* process arguments *******************************************/ /***************************************************************/ - char *vertexfile=0; - vector3 axis={0,0,1}; - double height=1.5; - vector3 test_point={0,0,0}; - vector3 test_dir={0,0,1}; - double a = 0.2, b=0.3; + char *vertexfile = 0; + vector3 axis = {0, 0, 1}; + double height = 1.5; + vector3 test_point = {0, 0, 0}; + vector3 test_dir = {0, 0, 1}; + double a = 0.2, b = 0.3; int narg; - for(narg=1; narg=argc) usage("too few arguments to --axis"); - sscanf(argv[narg+1],"%le",&(axis.x)); - sscanf(argv[narg+2],"%le",&(axis.y)); - sscanf(argv[narg+3],"%le",&(axis.z)); - narg+=3; - } - else if (!strcmp(argv[narg],"--point")) - { if (narg+3>=argc) usage("too few arguments to --point"); - sscanf(argv[narg+1],"%le",&(test_point.x)); - sscanf(argv[narg+2],"%le",&(test_point.y)); - sscanf(argv[narg+3],"%le",&(test_point.z)); - narg+=3; - } - else if (!strcmp(argv[narg],"--line")) - { if (narg+6>=argc) usage("too few arguments to --line"); - vector3 v1,v2; - sscanf(argv[narg+1],"%le",&(v1.x)); - sscanf(argv[narg+2],"%le",&(v1.y)); - sscanf(argv[narg+3],"%le",&(v1.z)); - sscanf(argv[narg+4],"%le",&(v2.x)); - sscanf(argv[narg+5],"%le",&(v2.y)); - sscanf(argv[narg+6],"%le",&(v2.z)); - printf("Min distance=%e\n",min_distance_to_line_segment(test_point,v1,v2)); - narg+=6; - } - else if (!strcmp(argv[narg],"--dir")) - { if (narg+3>=argc) usage("too few arguments to --lineseg"); - sscanf(argv[narg+1],"%le",&(test_dir.x)); - sscanf(argv[narg+2],"%le",&(test_dir.y)); - sscanf(argv[narg+3],"%le",&(test_dir.z)); - narg+=3; - } - else if (!strcmp(argv[narg],"--height")) - sscanf(argv[++narg],"%le",&height); - else if (!strcmp(argv[narg],"--a")) - sscanf(argv[++narg],"%le",&a); - else if (!strcmp(argv[narg],"--b")) - sscanf(argv[++narg],"%le",&b); - else + for (narg = 1; narg < argc - 1; narg++) { + if (!strcmp(argv[narg], "--vertexfile")) + vertexfile = argv[++narg]; + else if (!strcmp(argv[narg], "--axis")) { + if (narg + 3 >= argc) usage("too few arguments to --axis"); + sscanf(argv[narg + 1], "%le", &(axis.x)); + sscanf(argv[narg + 2], "%le", &(axis.y)); + sscanf(argv[narg + 3], "%le", &(axis.z)); + narg += 3; + } + else if (!strcmp(argv[narg], "--point")) { + if (narg + 3 >= argc) usage("too few arguments to --point"); + sscanf(argv[narg + 1], "%le", &(test_point.x)); + sscanf(argv[narg + 2], "%le", &(test_point.y)); + sscanf(argv[narg + 3], "%le", &(test_point.z)); + narg += 3; + } + else if (!strcmp(argv[narg], "--line")) { + if (narg + 6 >= argc) usage("too few arguments to --line"); + vector3 v1, v2; + sscanf(argv[narg + 1], "%le", &(v1.x)); + sscanf(argv[narg + 2], "%le", &(v1.y)); + sscanf(argv[narg + 3], "%le", &(v1.z)); + sscanf(argv[narg + 4], "%le", &(v2.x)); + sscanf(argv[narg + 5], "%le", &(v2.y)); + sscanf(argv[narg + 6], "%le", &(v2.z)); + printf("Min distance=%e\n", min_distance_to_line_segment(test_point, v1, v2)); + narg += 6; + } + else if (!strcmp(argv[narg], "--dir")) { + if (narg + 3 >= argc) usage("too few arguments to --lineseg"); + sscanf(argv[narg + 1], "%le", &(test_dir.x)); + sscanf(argv[narg + 2], "%le", &(test_dir.y)); + sscanf(argv[narg + 3], "%le", &(test_dir.z)); + narg += 3; + } + else if (!strcmp(argv[narg], "--height")) + sscanf(argv[++narg], "%le", &height); + else if (!strcmp(argv[narg], "--a")) + sscanf(argv[++narg], "%le", &a); + else if (!strcmp(argv[narg], "--b")) + sscanf(argv[++narg], "%le", &b); + else usage("unknown argument"); - } + } if (!vertexfile) usage("no --vertexfile specified"); /***************************************************************/ /* read vertices from vertex file and create prism *************/ /***************************************************************/ - vector3 *vertices=0; - int num_vertices=0; - FILE *f=fopen(vertexfile,"r"); + vector3 *vertices = 0; + int num_vertices = 0; + FILE *f = fopen(vertexfile, "r"); if (!f) usage("could not open vertexfile"); char Line[100]; - int LineNum=0; - while( fgets(Line,100,f) ) - { if (Line[0]=='\n' || Line[0]=='#') continue; - num_vertices++; - vector3 v; - if ( 3!=sscanf(Line,"%le %le %le\n",&(v.x),&(v.y),&(v.z)) ) - { fprintf(stderr,"bad vertex on line %i of %s",num_vertices,vertexfile); - exit(1); - } - vertices = (vector3 *)realloc(vertices, num_vertices*sizeof(vector3)); - vertices[num_vertices-1]=v; - } + int LineNum = 0; + while (fgets(Line, 100, f)) { + if (Line[0] == '\n' || Line[0] == '#') continue; + num_vertices++; + vector3 v; + if (3 != sscanf(Line, "%le %le %le\n", &(v.x), &(v.y), &(v.z))) { + fprintf(stderr, "bad vertex on line %i of %s", num_vertices, vertexfile); + exit(1); + } + vertices = (vector3 *)realloc(vertices, num_vertices * sizeof(vector3)); + vertices[num_vertices - 1] = v; + } fclose(f); - geometric_object the_prism=make_prism(NULL, vertices, num_vertices, height, axis); - prism *prsm=the_prism.subclass.prism_data; + geometric_object the_prism = make_prism(NULL, vertices, num_vertices, height, axis); + prism *prsm = the_prism.subclass.prism_data; prism2gmsh(prsm, "test-prism.pp"); prism2gnuplot(prsm, "test-prism.gp"); - f=fopen("test-point.gp","w"); - fprintf(f,"%e %e %e\n",test_point.x,test_point.y,test_point.z); + f = fopen("test-point.gp", "w"); + fprintf(f, "%e %e %e\n", test_point.x, test_point.y, test_point.z); fclose(f); printf("Wrote prism description to GNUPLOT file test-prism.gp.\n"); printf("Wrote prism description to GMSH file test-prism.geo.\n"); geom_box prism_box; my_get_prism_bounding_box(prsm, &prism_box); - f=fopen("test-prism-bb.gp","w"); - fprintf(f,"%e %e %e\n",prism_box.low.x, prism_box.low.y, prism_box.low.z); - fprintf(f,"%e %e %e\n",prism_box.high.x, prism_box.low.y, prism_box.low.z); - fprintf(f,"%e %e %e\n",prism_box.high.x, prism_box.high.y, prism_box.low.z); - fprintf(f,"%e %e %e\n",prism_box.low.x, prism_box.high.y, prism_box.low.z); - fprintf(f,"%e %e %e\n\n\n",prism_box.low.x, prism_box.low.y, prism_box.low.z); - - fprintf(f,"%e %e %e\n",prism_box.low.x, prism_box.low.y, prism_box.high.z); - fprintf(f,"%e %e %e\n",prism_box.high.x, prism_box.low.y, prism_box.high.z); - fprintf(f,"%e %e %e\n",prism_box.high.x, prism_box.high.y, prism_box.high.z); - fprintf(f,"%e %e %e\n",prism_box.low.x, prism_box.high.y, prism_box.high.z); - fprintf(f,"%e %e %e\n\n\n",prism_box.low.x, prism_box.low.y, prism_box.high.z); + f = fopen("test-prism-bb.gp", "w"); + fprintf(f, "%e %e %e\n", prism_box.low.x, prism_box.low.y, prism_box.low.z); + fprintf(f, "%e %e %e\n", prism_box.high.x, prism_box.low.y, prism_box.low.z); + fprintf(f, "%e %e %e\n", prism_box.high.x, prism_box.high.y, prism_box.low.z); + fprintf(f, "%e %e %e\n", prism_box.low.x, prism_box.high.y, prism_box.low.z); + fprintf(f, "%e %e %e\n\n\n", prism_box.low.x, prism_box.low.y, prism_box.low.z); + + fprintf(f, "%e %e %e\n", prism_box.low.x, prism_box.low.y, prism_box.high.z); + fprintf(f, "%e %e %e\n", prism_box.high.x, prism_box.low.y, prism_box.high.z); + fprintf(f, "%e %e %e\n", prism_box.high.x, prism_box.high.y, prism_box.high.z); + fprintf(f, "%e %e %e\n", prism_box.low.x, prism_box.high.y, prism_box.high.z); + fprintf(f, "%e %e %e\n\n\n", prism_box.low.x, prism_box.low.y, prism_box.high.z); printf("Wrote bounding box to GNUPLOT file test-prism-bb.gp.\n"); /***************************************************************/ /* test point inclusion, normal to object, and line-segment */ /* intersection with specified data */ /***************************************************************/ - boolean in_prism=point_in_objectp(test_point,the_prism); - vector3 nhat=normal_to_object(test_point, the_prism); - double s= intersect_line_segment_with_object(test_point, test_dir, the_prism, a, b); - printf("point {%e,%e,%e}: \n",test_point.x,test_point.y,test_point.z); + boolean in_prism = point_in_objectp(test_point, the_prism); + vector3 nhat = normal_to_object(test_point, the_prism); + double s = intersect_line_segment_with_object(test_point, test_dir, the_prism, a, b); + printf("point {%e,%e,%e}: \n", test_point.x, test_point.y, test_point.z); printf(" %s prism\n", in_prism ? "in" : "not in"); - printf(" normal to prism: {%e,%e,%e}\n",nhat.x,nhat.y,nhat.z); - printf(" intersection with line segment {%e,%e,%e} + (%e,%e)*{%e,%e,%e}: %e\n", - test_point.x, test_point.y, test_point.z, - a,b,test_dir.x, test_dir.y, test_dir.z,s); + printf(" normal to prism: {%e,%e,%e}\n", nhat.x, nhat.y, nhat.z); + printf(" intersection with line segment {%e,%e,%e} + (%e,%e)*{%e,%e,%e}: %e\n", test_point.x, + test_point.y, test_point.z, a, b, test_dir.x, test_dir.y, test_dir.z, s); }