├── .gitignore ├── .travis.yml ├── LICENCE.txt ├── Makefile ├── README.md ├── command.make ├── dub.json ├── site └── readme_as_index └── source └── scid ├── bindings └── lapack │ ├── dlapack.d │ └── lapack.d ├── calculus.d ├── constants.d ├── core ├── fortran.d ├── memory.d ├── meta.d ├── testing.d └── traits.d ├── functions.d ├── internal └── calculus │ ├── integrate_qk.d │ └── integrate_qng.d ├── linalg.d ├── matrix.d ├── nonlinear.d ├── ports ├── intde │ ├── intde1.d │ └── intde2.d ├── linpack │ └── gtsl.d ├── minpack │ ├── dogleg.d │ ├── enorm.d │ ├── fdjac1.d │ ├── hybrd.d │ ├── qform.d │ ├── qrfac.d │ ├── r1mpyq.d │ └── r1updt.d ├── napack │ ├── addchg.d │ ├── quasi.d │ └── stopit.d └── quadpack │ ├── qag.d │ ├── qage.d │ ├── qagi.d │ ├── qagie.d │ ├── qagp.d │ ├── qagpe.d │ ├── qags.d │ ├── qagse.d │ ├── qawc.d │ ├── qawce.d │ ├── qawf.d │ ├── qawfe.d │ ├── qawo.d │ ├── qawoe.d │ ├── qaws.d │ ├── qawse.d │ ├── qc25c.d │ ├── qc25f.d │ ├── qc25s.d │ ├── qcheb.d │ ├── qelg.d │ ├── qk15.d │ ├── qk15i.d │ ├── qk15w.d │ ├── qk21.d │ ├── qk31.d │ ├── qk41.d │ ├── qk51.d │ ├── qk61.d │ ├── qmomo.d │ ├── qng.d │ ├── qpsrt.d │ ├── qwgtc.d │ ├── qwgtf.d │ └── qwgts.d ├── types.d └── util.d /.gitignore: -------------------------------------------------------------------------------- 1 | # Files generated by editors and IDEs 2 | *.swp 3 | project.sublime-project 4 | 5 | # Files generated by build systems 6 | /build 7 | /doc 8 | /import 9 | /lib 10 | scid.pc 11 | .dub 12 | dub.selections.json 13 | __test__library__ 14 | libscid.a 15 | /site 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | 3 | os: 4 | - linux 5 | - osx 6 | 7 | osx_image: xcode9.3 8 | 9 | language: d 10 | 11 | d: 12 | - dmd-2.080.0 13 | - dmd-2.079.1 14 | - dmd-2.078.3 15 | - dmd-2.077.1 16 | - dmd-2.076.1 17 | - dmd-2.075.1 18 | - dmd-2.074.1 19 | - ldc-1.9.0 20 | - ldc-1.8.0 21 | - ldc-1.7.0 22 | - ldc-1.6.0 23 | - ldc-1.5.0 24 | - ldc-beta 25 | - dmd-beta 26 | - dmd 27 | - ldc 28 | 29 | matrix: 30 | allow_failures: 31 | - d: dmd-beta 32 | - d: ldc-beta 33 | 34 | addons: 35 | apt: 36 | packages: 37 | liblapack-dev 38 | -------------------------------------------------------------------------------- /LICENCE.txt: -------------------------------------------------------------------------------- 1 | Boost Software License - Version 1.0 - August 17th, 2003 2 | 3 | Permission is hereby granted, free of charge, to any person or organization 4 | obtaining a copy of the software and accompanying documentation covered by 5 | this license (the "Software") to use, reproduce, display, distribute, 6 | execute, and transmit the Software, and to prepare derivative works of the 7 | Software, and to permit third-parties to whom the Software is furnished to 8 | do so, all subject to the following: 9 | 10 | The copyright notices in the Software and this entire statement, including 11 | the above license grant, this restriction and the following disclaimer, 12 | must be included in all copies of the Software, in whole or in part, and 13 | all derivative works of the Software, unless such copies or derivative 14 | works are solely in the form of machine-executable object code generated by 15 | a source language processor. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT 20 | SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE 21 | FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE, 22 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | DEALINGS IN THE SOFTWARE. 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | export PROJECT_NAME = scid 3 | export AUTHOR = "Lars T. Kyllingstad" 4 | export DESCRIPTION = "A collection of numerical routines and bindings for the D programming language" 5 | export REPO_SRC_DIR = "scid" 6 | export LOGO_SRC = 7 | export MAJOR_VERSION = 0 8 | export MINOR_VERSION = 3 9 | export PATCH_VERSION = 0 10 | export PROJECT_VERSION = $(MAJOR_VERSION).$(MINOR_VERSION).$(PATCH_VERSION) 11 | export LICENSE = "Boost License 1.0" 12 | export ROOT_SOURCE_DIR = "source" 13 | export LIBS = lapack blas gfortran 14 | DDOCFILES = modules.ddoc settings.ddoc cutedoc.ddoc 15 | 16 | # include some command 17 | include command.make 18 | 19 | SOURCES = $(getSource) 20 | OBJECTS = $(patsubst %.d,$(BUILD_PATH)$(PATH_SEP)%.o, $(SOURCES)) 21 | PICOBJECTS = $(patsubst %.d,$(BUILD_PATH)$(PATH_SEP)%.pic.o,$(SOURCES)) 22 | HEADERS = $(patsubst %.d,$(IMPORT_PATH)$(PATH_SEP)%.di, $(SOURCES)) 23 | DOCUMENTATIONS = $(patsubst %.d,$(DOC_PATH)$(PATH_SEP)%.html, $(SOURCES)) 24 | DDOCUMENTATIONS = $(patsubst %.d,$(DDOC_PATH)$(PATH_SEP)%.html, $(SOURCES)) 25 | DDOC_FLAGS = $(foreach macro,$(DDOCFILES), $(DDOC_MACRO)$(macro)) 26 | DCFLAGS_IMPORT += $(foreach dir,$(ROOT_SOURCE_DIR), -I$(dir)) 27 | LIBS_TO_LINK = $(foreach lib,$(LIBS), $(LINKERFLAG)-l$(lib)) 28 | space := 29 | space += 30 | 31 | stripBugfix = $(subst $(space),.,$(strip $(wordlist 1, 2, $(subst ., ,$(1))))) 32 | 33 | define make-lib 34 | $(MKDIR) $(DLIB_PATH) 35 | $(AR) rcs $(DLIB_PATH)$(PATH_SEP)$@ $^ 36 | $(RANLIB) $(DLIB_PATH)$(PATH_SEP)$@ 37 | endef 38 | 39 | ############# BUILD ############# 40 | all: static-lib header doc pkgfile-static 41 | @echo ------------------ Building $^ done 42 | all-shared: shared-lib header doc pkgfile-shared 43 | @echo ------------------ Building $^ done 44 | 45 | .PHONY : pkgfile 46 | .PHONY : doc 47 | .PHONY : ddoc 48 | .PHONY : clean 49 | 50 | static-lib: $(STATIC_LIBNAME) 51 | 52 | shared-lib: $(SHARED_LIBNAME) 53 | 54 | header: $(HEADERS) 55 | 56 | doc: $(DOCUMENTATIONS) 57 | @echo ------------------ Building Doc done 58 | 59 | ddoc: settings.ddoc $(DDOCUMENTATIONS) 60 | $(DC) $(DDOC_FLAGS) index.d $(DF)$(DDOC_PATH)$(PATH_SEP)index.html 61 | @echo ------------------ Building DDoc done 62 | 63 | geany-tag: 64 | @echo ------------------ Building geany tag 65 | $(MKDIR) geany_config 66 | geany -c geany_config -g $(PROJECT_NAME).d.tags $(SOURCES) 67 | 68 | pkgfile-shared: 69 | @echo ------------------ Building pkg-config file 70 | @echo "# Package Information for pkg-config" > $(PKG_CONFIG_FILE) 71 | @echo "# Author: $(AUTHOR)" >> $(PKG_CONFIG_FILE) 72 | @echo "# Created: `date`" >> $(PKG_CONFIG_FILE) 73 | @echo "# Licence: $(LICENSE)" >> $(PKG_CONFIG_FILE) 74 | @echo >> $(PKG_CONFIG_FILE) 75 | @echo prefix=$(PREFIX) >> $(PKG_CONFIG_FILE) 76 | @echo exec_prefix=$(PREFIX) >> $(PKG_CONFIG_FILE) 77 | @echo libdir=$(LIB_DIR) >> $(PKG_CONFIG_FILE) 78 | @echo includedir=$(INCLUDE_DIR) >> $(PKG_CONFIG_FILE) 79 | @echo >> $(PKG_CONFIG_FILE) 80 | @echo Name: "$(PROJECT_NAME)" >> $(PKG_CONFIG_FILE) 81 | @echo Description: "$(DESCRIPTION)" >> $(PKG_CONFIG_FILE) 82 | @echo Version: "$(PROJECT_VERSION)" >> $(PKG_CONFIG_FILE) 83 | @echo Libs: $(LINKERFLAG)-l$(PROJECT_NAME)-$(COMPILER) >> $(PKG_CONFIG_FILE) 84 | @echo Cflags: -I$(INCLUDE_DIR)$(PATH_SEP)$(PROJECT_NAME) $(LDCFLAGS)>> $(PKG_CONFIG_FILE) 85 | @echo >> $(PKG_CONFIG_FILE) 86 | 87 | pkgfile-static: 88 | @echo ------------------ Building pkg-config file 89 | @echo "# Package Information for pkg-config" > $(PKG_CONFIG_FILE) 90 | @echo "# Author: $(AUTHOR)" >> $(PKG_CONFIG_FILE) 91 | @echo "# Created: `date`" >> $(PKG_CONFIG_FILE) 92 | @echo "# Licence: $(LICENSE)" >> $(PKG_CONFIG_FILE) 93 | @echo >> $(PKG_CONFIG_FILE) 94 | @echo prefix=$(PREFIX) >> $(PKG_CONFIG_FILE) 95 | @echo exec_prefix=$(PREFIX) >> $(PKG_CONFIG_FILE) 96 | @echo libdir=$(LIB_DIR) >> $(PKG_CONFIG_FILE) 97 | @echo includedir=$(INCLUDE_DIR) >> $(PKG_CONFIG_FILE) 98 | @echo >> $(PKG_CONFIG_FILE) 99 | @echo Name: "$(PROJECT_NAME)" >> $(PKG_CONFIG_FILE) 100 | @echo Description: "$(DESCRIPTION)" >> $(PKG_CONFIG_FILE) 101 | @echo Version: "$(PROJECT_VERSION)" >> $(PKG_CONFIG_FILE) 102 | @echo Libs: $(LIB_DIR)$(PATH_SEP)$(STATIC_LIBNAME) >> $(PKG_CONFIG_FILE) 103 | @echo Cflags: -I$(INCLUDE_DIR)$(PATH_SEP)$(PROJECT_NAME) $(LDCFLAGS)>> $(PKG_CONFIG_FILE) 104 | @echo >> $(PKG_CONFIG_FILE) 105 | 106 | settings.ddoc: 107 | @echo "PROJECTNAME = $(PROJECT_NAME)" > settings.ddoc 108 | @echo "LINKPREFIX = $(LINKERFLAG)" >> settings.ddoc 109 | @echo "REPOSRCDIR = $(REPO_SRC_DIR)" >> settings.ddoc 110 | @echo "ROOT = $(ROOT_SOURCE_DIR)" >> settings.ddoc 111 | @echo "LOGOSRC = $(LOGO_SRC)" >> settings.ddoc 112 | @echo "LOGOALT = $(PROJECT_NAME)" >> settings.ddoc 113 | 114 | # For build lib need create object files and after run make-lib 115 | $(STATIC_LIBNAME): $(OBJECTS) 116 | @echo ------------------ Building static library 117 | $(make-lib) 118 | 119 | # For build shared lib need create shared object files 120 | $(SHARED_LIBNAME): $(PICOBJECTS) 121 | @echo ------------------ Building shared library 122 | $(MKDIR) $(DLIB_PATH) 123 | $(DC) $(LIBS_TO_LINK) -shared $(SONAME_FLAG) $@.$(MAJOR_VERSION) $(OUTPUT)$(DLIB_PATH)$(PATH_SEP)$@.$(PROJECT_VERSION) $^ 124 | #$(CC) -l$(PHOBOS) -l$(DRUNTIME) -shared -Wl,-soname,$@.$(MAJOR_VERSION) -o $(DLIB_PATH)$(PATH_SEP)$@.$(PROJECT_VERSION) $^ 125 | 126 | # create object files 127 | $(BUILD_PATH)$(PATH_SEP)%.o : %.d 128 | $(DC) $(DCFLAGS) $(DCFLAGS_LINK) $(DCFLAGS_IMPORT) -c $< $(OUTPUT)$@ 129 | 130 | # create shared object files 131 | $(BUILD_PATH)$(PATH_SEP)%.pic.o : %.d 132 | $(DC) $(DCFLAGS) $(DCFLAGS_LINK) $(FPIC) $(DCFLAGS_IMPORT) -c $< $(OUTPUT)$@ 133 | 134 | # Generate Header files 135 | $(IMPORT_PATH)$(PATH_SEP)%.di : %.d 136 | $(DC) $(DCFLAGS) $(DCFLAGS_LINK) $(DCFLAGS_IMPORT) -c $(NO_OBJ) $< $(HF)$@ 137 | 138 | # Generate Documentation 139 | $(DOC_PATH)$(PATH_SEP)%.html : %.d 140 | $(DC) $(DCFLAGS) $(DCFLAGS_LINK) $(DCFLAGS_IMPORT) -c $(NO_OBJ) $< $(DF)$@ 141 | 142 | # Generate ddoc Documentation 143 | $(DDOC_PATH)$(PATH_SEP)%.html : %.d 144 | $(DC) $(DCFLAGS) $(DCFLAGS_LINK) $(DCFLAGS_IMPORT) -c $(NO_OBJ) $(DDOC_FLAGS) $< $(DF)$@ 145 | 146 | ############# CLEAN ############# 147 | clean: clean-objects clean-static-lib clean-doc clean-header clean-pkgfile 148 | @echo ------------------ Cleaning $^ done 149 | 150 | clean-shared: clean-shared-objects clean-shared-lib 151 | @echo ------------------ Cleaning $^ done 152 | 153 | clean-objects: 154 | $(RM) $(OBJECTS) 155 | @echo ------------------ Cleaning objects done 156 | 157 | clean-shared-objects: 158 | $(RM) $(PICOBJECTS) 159 | @echo ------------------ Cleaning shared-object done 160 | 161 | clean-static-lib: 162 | $(RM) $(DLIB_PATH)$(PATH_SEP)$(STATIC_LIBNAME) 163 | @echo ------------------ Cleaning static-lib done 164 | 165 | clean-shared-lib: 166 | $(RM) $(DLIB_PATH)$(PATH_SEP)$(SHARED_LIBNAME).$(PROJECT_VERSION) 167 | @echo ------------------ Cleaning shared-lib done 168 | 169 | clean-header: 170 | $(RM) $(HEADERS) 171 | @echo ------------------ Cleaning header done 172 | 173 | clean-doc: 174 | $(RM) $(DOCUMENTATIONS) 175 | $(RM) $(DOC_PATH) 176 | @echo ------------------ Cleaning doc done 177 | 178 | clean-ddoc: 179 | $(RM) $(DDOC_PATH)$(PATH_SEP)index.html 180 | $(RM) $(DDOCUMENTATIONS) 181 | $(RM) $(DDOC_PATH)$(PATH_SEP)$(PROJECT_NAME) 182 | $(RM) $(DDOC_PATH) 183 | @echo ------------------ Cleaning ddoc done 184 | 185 | clean-geany-tag: 186 | $(RM) geany_config $(PROJECT_NAME).d.tags 187 | @echo ------------------ Cleaning geany tag done 188 | 189 | clean-pkgfile: 190 | $(RM) $(PKG_CONFIG_FILE) 191 | @echo ------------------ Cleaning pkgfile done 192 | 193 | ############# INSTALL ############# 194 | 195 | install: install-static-lib install-doc install-header install-pkgfile 196 | @echo ------------------ Installing $^ done 197 | 198 | install-shared: install-shared-lib install-doc install-header install-pkgfile 199 | @echo ------------------ Installing $^ done 200 | 201 | install-static-lib: 202 | $(MKDIR) $(DESTDIR)$(LIB_DIR) 203 | $(CP) $(DLIB_PATH)$(PATH_SEP)$(STATIC_LIBNAME) $(DESTDIR)$(LIB_DIR) 204 | @echo ------------------ Installing static-lib done 205 | 206 | install-shared-lib: 207 | $(MKDIR) $(DESTDIR)$(LIB_DIR) 208 | $(CP) $(DLIB_PATH)$(PATH_SEP)$(SHARED_LIBNAME).$(PROJECT_VERSION) $(DESTDIR)$(LIB_DIR) 209 | cd $(DESTDIR)$(LIB_DIR)$(PATH_SEP) && $(LN) $(SHARED_LIBNAME).$(PROJECT_VERSION) $(SHARED_LIBNAME).$(MAJOR_VERSION) 210 | cd $(DESTDIR)$(LIB_DIR)$(PATH_SEP) && $(LN) $(SHARED_LIBNAME).$(MAJOR_VERSION) $(SHARED_LIBNAME) 211 | @echo ------------------ Installing shared-lib done 212 | 213 | install-header: 214 | $(MKDIR) $(DESTDIR)$(INCLUDE_DIR) 215 | $(CP) $(IMPORT_PATH)$(PATH_SEP)$(PROJECT_NAME) $(DESTDIR)$(INCLUDE_DIR) 216 | @echo ------------------ Installing header done 217 | 218 | install-doc: 219 | $(MKDIR) $(DESTDIR)$(DATA_DIR)$(PATH_SEP)doc$(PATH_SEP)$(PROJECT_NAME)$(PATH_SEP)normal_doc$(PATH_SEP) 220 | $(CP) $(DOC_PATH)$(PATH_SEP)* $(DESTDIR)$(DATA_DIR)$(PATH_SEP)doc$(PATH_SEP)$(PROJECT_NAME)$(PATH_SEP)normal_doc$(PATH_SEP) 221 | @echo ------------------ Installing doc done 222 | 223 | install-ddoc: 224 | $(MKDIR) $(DESTDIR)$(DATA_DIR)$(PATH_SEP)doc$(PATH_SEP)$(PROJECT_NAME)$(PATH_SEP)cute_doc$(PATH_SEP) 225 | $(CP) $(DDOC_PATH)$(PATH_SEP)* $(DESTDIR)$(DATA_DIR)$(PATH_SEP)doc$(PATH_SEP)$(PROJECT_NAME)$(PATH_SEP)cute_doc$(PATH_SEP) 226 | @echo ------------------ Installing ddoc done 227 | 228 | install-geany-tag: 229 | $(MKDIR) $(DESTDIR)$(DATA_DIR)$(PATH_SEP)geany$(PATH_SEP)tags$(PATH_SEP) 230 | $(CP) $(PROJECT_NAME).d.tags $(DESTDIR)$(DATA_DIR)$(PATH_SEP)geany$(PATH_SEP)tags$(PATH_SEP) 231 | @echo ------------------ Installing geany tag done 232 | 233 | install-pkgfile: 234 | $(MKDIR) $(DESTDIR)$(PKGCONFIG_DIR) 235 | $(CP) $(PKG_CONFIG_FILE) $(DESTDIR)$(PKGCONFIG_DIR)$(PATH_SEP)$(PROJECT_NAME).pc 236 | @echo ------------------ Installing pkgfile done 237 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/DlangScience/scid.svg?branch=master)](https://travis-ci.org/DlangScience/scid) 2 | SciD 3 | ==== 4 | 5 | SciD is a collection of numerical routines and bindings written in and for 6 | the D programming language. It contains: 7 | 8 | * `scid.calculus`: Numerical integration (quadrature) and differentiation. 9 | * `scid.constants`: Fundamental constants of mathematics and Nature. 10 | * `scid.functions`: Mathematical special functions. 11 | * `scid.linalg`: Linear algebra (i.e., nice interfaces to a few LAPACK functions). 12 | * `scid.matrix`: LAPACK-compatible matrix view of ordinary arrays. 13 | * `scid.nonlinear`: Methods for nonlinear equation solving. 14 | 15 | There are several ways to get SciD: 16 | 17 | * It is available as a [Dub package](http://code.dlang.org/packages/scid). 18 | * Users of Debian, Ubuntu, Linux Mint and similar operating systems may 19 | install it from the [D-APT package repository](http://d-apt.sourceforge.net/). 20 | * You can clone the [GitHub repository](https://github.com/DlangScience/scid) 21 | and build it yourself. 22 | 23 | Please submit questions and bug reports using the 24 | [GitHub issue tracker](https://github.com/DlangScience/scid/issues). 25 | 26 | API documentation 27 | ----------------- 28 | 29 | [Here](https://dlangscience.github.io/scid/api/) 30 | 31 | Requirements 32 | ------------ 33 | All you need in order to use SciD is: 34 | 35 | * A somewhat up-to-date D compiler 36 | * The LAPACK library (and, by extension, a BLAS library) 37 | 38 | Contributing 39 | ------------ 40 | Contributions are very welcome! Please submit your work as 41 | [pull requests on GitHub](https://github.com/DlangScience/scid/pulls). 42 | By submitting a pull request, you implicitly accept that your contribution 43 | is placed under the same licence as SciD. See LICENCE.txt for details. 44 | 45 | While there is no formal coding style guide for SciD, new code is expected to 46 | follow the same style as existing code (which is more or less conventional 47 | in the D community anyway). 48 | 49 | Use four spaces for indentation (we don't need no stinkin' tabs!) , and UNIX 50 | line endings (a single newline). 51 | -------------------------------------------------------------------------------- /command.make: -------------------------------------------------------------------------------- 1 | ifdef SystemRoot 2 | OS = "Windows" 3 | STATIC_LIB_EXT = .lib 4 | DYNAMIC_LIB_EXT = .dll 5 | PATH_SEP =\ 6 | message = @(echo $1) 7 | SHELL = cmd.exe 8 | Filter = %/linux/%.d %/darwin/%.d %/freebsd/%.d %/solaris/%.d 9 | getSource =$(shell dir $(ROOT_SOURCE_DIR)$(PATH_SEP)$(REPO_SRC_DIR) /s /b) 10 | else ifneq (,$(findstring /mingw/,$PATH)) 11 | OS = "MinGW" 12 | STATIC_LIB_EXT = .lib 13 | DYNAMIC_LIB_EXT = .dll 14 | PATH_SEP =\ 15 | message = @(echo $1) 16 | SHELL = cmd.exe 17 | Filter = %/linux/%.d %/darwin/%.d %/freebsd/%.d %/solaris/%.d 18 | getSource =$(shell dir $(ROOT_SOURCE_DIR)$(PATH_SEP)$(REPO_SRC_DIR) /s /b) 19 | else 20 | SHELL = sh 21 | PATH_SEP =/ 22 | getSource =$(shell find $(ROOT_SOURCE_DIR)$(PATH_SEP)$(REPO_SRC_DIR) -name "*.d") 23 | ifneq (,$(findstring /cygdrive/,$PATH)) 24 | OS = "Cygwin" 25 | STATIC_LIB_EXT = .a 26 | DYNAMIC_LIB_EXT = .so 27 | message = @(echo \033[31m $1 \033[0;0m1) 28 | Filter = %/win32/%.d %/darwin/%.d %/freebsd/%.d %/solaris/%.d 29 | else ifeq ($(shell uname), Linux) 30 | OS = "Linux" 31 | STATIC_LIB_EXT = .a 32 | DYNAMIC_LIB_EXT = .so 33 | message = @(echo \033[31m $1 \033[0;0m1) 34 | Filter = %/win32/%.d %/darwin/%.d %/freebsd/%.d %/solaris/%.d 35 | else ifeq ($(shell uname), Solaris) 36 | STATIC_LIB_EXT = .a 37 | DYNAMIC_LIB_EXT = .so 38 | OS = "Solaris" 39 | message = @(echo \033[31m $1 \033[0;0m1) 40 | Filter = %/win32/%.d %/linux/%.d %/darwin/%.d %/freebsd/%.d 41 | else ifeq ($(shell uname),Freebsd) 42 | STATIC_LIB_EXT = .a 43 | DYNAMIC_LIB_EXT = .so 44 | OS = "Freebsd" 45 | message = @(echo \033[31m $1 \033[0;0m1) 46 | Filter = %/win32/%.d %/linux/%.d %/darwin/%.d %/solaris/%.d 47 | else ifeq ($(shell uname),Darwin) 48 | STATIC_LIB_EXT = .a 49 | DYNAMIC_LIB_EXT = .so 50 | OS = "Darwin" 51 | message = @(echo \033[31m $1 \033[0;0m1) 52 | Filter = %/win32/%.d %/linux/%.d %/freebsd/%.d %/solaris/%.d 53 | endif 54 | endif 55 | 56 | # Define command for copy, remove and create file/dir 57 | ifeq ($(OS),"Windows") 58 | RM = del /Q 59 | CP = copy /Y 60 | MKDIR = mkdir 61 | MV = move 62 | LN = mklink 63 | else ifeq ($(OS),"Linux") 64 | RM = rm -fr 65 | CP = cp -fr 66 | MKDIR = mkdir -p 67 | MV = mv 68 | LN = ln -s 69 | else ifeq ($(OS),"Freebsd") 70 | RM = rm -fr 71 | CP = cp -fr 72 | MKDIR = mkdir -p 73 | MV = mv 74 | LN = ln -s 75 | else ifeq ($(OS),"Solaris") 76 | RM = rm -fr 77 | CP = cp -fr 78 | MKDIR = mkdir -p 79 | MV = mv 80 | LN = ln -s 81 | else ifeq ($(OS),"Darwin") 82 | RM = rm -fr 83 | CP = cp -fr 84 | MKDIR = mkdir -p 85 | MV = mv 86 | LN = ln -s 87 | endif 88 | 89 | # If compiler is not define try to find it 90 | ifndef DC 91 | ifneq ($(strip $(shell which dmd 2>/dev/null)),) 92 | DC=dmd 93 | else ifneq ($(strip $(shell which ldc 2>/dev/null)),) 94 | DC=ldc 95 | else ifneq ($(strip $(shell which ldc2 2>/dev/null)),) 96 | DC=ldc2 97 | else 98 | DC=gdc 99 | endif 100 | endif 101 | 102 | # Define flag for gdc other 103 | ifeq ($(DC),gdc) 104 | DCFLAGS = -O2 -fdeprecated 105 | LINKERFLAG= -Xlinker 106 | OUTPUT = -o 107 | HF = -fintfc-file= 108 | DF = -fdoc-file= 109 | NO_OBJ = -fsyntax-only 110 | DDOC_MACRO= -fdoc-inc= 111 | else 112 | DCFLAGS = -O -d 113 | LINKERFLAG= -L 114 | OUTPUT = -of 115 | HF = -Hf 116 | DF = -Df 117 | NO_OBJ = -o- 118 | DDOC_MACRO= 119 | endif 120 | 121 | #define a suffix lib who inform is build with which compiler, name of phobos lib 122 | ifeq ($(DC),gdc) 123 | COMPILER = gdc 124 | VERSION = -fversion 125 | SONAME_FLAG = $(LINKERFLAG) -soname 126 | PHOBOS = gphobos2 127 | DRUNTIME = gdruntime 128 | else ifeq ($(DC),gdmd) 129 | COMPILER = gdc 130 | VERSION = -fversion 131 | SONAME_FLAG = $(LINKERFLAG) -soname 132 | PHOBOS = gphobos2 133 | DRUNTIME = gdruntime 134 | else ifeq ($(DC),ldc) 135 | COMPILER = ldc 136 | VERSION = -d-version 137 | SONAME_FLAG = -soname 138 | PHOBOS = phobos-ldc 139 | DRUNTIME = druntime-ldc 140 | else ifeq ($(DC),ldc2) 141 | COMPILER = ldc 142 | VERSION = -d-version 143 | SONAME_FLAG = -soname 144 | PHOBOS = phobos-ldc 145 | DRUNTIME = druntime-ldc 146 | else ifeq ($(DC),ldmd) 147 | COMPILER = ldc 148 | VERSION = -d-version 149 | SONAME_FLAG = -soname 150 | PHOBOS = phobos2-ldc 151 | DRUNTIME = druntime-ldc 152 | else ifeq ($(DC),dmd) 153 | COMPILER = dmd 154 | VERSION = -version 155 | SONAME_FLAG = $(LINKERFLAG)-soname 156 | PHOBOS = phobos2 157 | DRUNTIME = druntime 158 | else ifeq ($(DC),dmd2) 159 | COMPILER = dmd 160 | VERSION = -d-version 161 | SONAME_FLAG = $(LINKERFLAG)-soname 162 | PHOBOS = phobos2 163 | DRUNTIME = druntime 164 | endif 165 | 166 | # Define relocation model for ldc or other 167 | ifneq (,$(findstring ldc,$(DC))) 168 | FPIC = -relocation-model=pic 169 | else 170 | FPIC = -fPIC 171 | endif 172 | 173 | # Add -ldl flag for linux 174 | ifeq ($(OS),"Linux") 175 | LDCFLAGS += $(LINKERFLAG)-ldl 176 | endif 177 | 178 | # If model are not given take the same as current system 179 | ifndef ARCH 180 | ifeq ($(OS),"Windows") 181 | ifeq ($(PROCESSOR_ARCHITECTURE), x86) 182 | ARCH = x86 183 | else 184 | ARCH = x86_64 185 | endif 186 | else 187 | ARCH = $(shell arch 2>/dev/null|| uname -m) 188 | endif 189 | endif 190 | ifndef MODEL 191 | ifeq ($(ARCH), x86_64) 192 | MODEL = 64 193 | else 194 | MODEL = 32 195 | endif 196 | endif 197 | 198 | ifeq ($(MODEL), 64) 199 | DCFLAGS += -m64 200 | LDCFLAGS += -m64 201 | else 202 | DCFLAGS += -m32 203 | LDCFLAGS += -m32 204 | endif 205 | 206 | ifndef DESTDIR 207 | DESTDIR = 208 | endif 209 | 210 | # Define var PREFIX, BIN_DIR, LIB_DIR, INCLUDE_DIR, DATA_DIR 211 | ifndef PREFIX 212 | ifeq ($(OS),"Windows") 213 | PREFIX = $(PROGRAMFILES) 214 | else ifeq ($(OS), "Linux") 215 | PREFIX = /usr/local 216 | else ifeq ($(OS), "Darwin") 217 | PREFIX = /usr/local 218 | endif 219 | endif 220 | 221 | ifndef BIN_DIR 222 | ifeq ($(OS), "Windows") 223 | BIN_DIR = $(PROGRAMFILES)\$(PROJECT_NAME)\bin 224 | else ifeq ($(OS), "Linux") 225 | BIN_DIR = $(PREFIX)/bin 226 | else ifeq ($(OS), "Darwin") 227 | BIN_DIR = $(PREFIX)/bin 228 | endif 229 | endif 230 | ifndef LIB_DIR 231 | ifeq ($(OS), "Windows") 232 | LIB_DIR = $(PREFIX)\$(PROJECT_NAME)\lib 233 | else ifeq ($(OS), "Linux") 234 | LIB_DIR = $(PREFIX)/lib 235 | else ifeq ($(OS), "Darwin") 236 | LIB_DIR = $(PREFIX)/lib 237 | endif 238 | endif 239 | 240 | ifndef INCLUDE_DIR 241 | ifeq ($(OS), "Windows") 242 | INCLUDE_DIR = $(PROGRAMFILES)\$(PROJECT_NAME)\import 243 | else 244 | INCLUDE_DIR = $(PREFIX)/include/d/ 245 | endif 246 | endif 247 | 248 | ifndef DATA_DIR 249 | ifeq ($(OS), "Windows") 250 | DATA_DIR = $(PROGRAMFILES)\$(PROJECT_NAME)\data 251 | else 252 | DATA_DIR = $(PREFIX)/share 253 | endif 254 | endif 255 | 256 | ifndef PKGCONFIG_DIR 257 | ifeq ($(OS), "Windows") 258 | PKGCONFIG_DIR = $(PROGRAMFILES)\$(PROJECT_NAME)\data 259 | else 260 | PKGCONFIG_DIR = $(DATA_DIR)/pkgconfig 261 | endif 262 | endif 263 | 264 | ifndef CC 265 | CC = gcc 266 | endif 267 | 268 | DLIB_PATH = ./lib 269 | IMPORT_PATH = ./import 270 | DOC_PATH = ./doc 271 | DDOC_PATH = ./ddoc 272 | BUILD_PATH = ./build 273 | 274 | DCFLAGS_IMPORT = 275 | DCFLAGS_LINK = $(LDCFLAGS) 276 | 277 | STATIC_LIBNAME = lib$(PROJECT_NAME)-$(COMPILER)$(STATIC_LIB_EXT) 278 | SHARED_LIBNAME = lib$(PROJECT_NAME)-$(COMPILER)$(DYNAMIC_LIB_EXT) 279 | 280 | PKG_CONFIG_FILE = $(PROJECT_NAME).pc 281 | 282 | MAKE = make 283 | AR = ar 284 | ARFLAGS = rcs 285 | RANLIB = ranlib 286 | 287 | export AR 288 | export ARCH 289 | export ARFLAGS 290 | export BIN_DIR 291 | export BUILD_PATH 292 | export CC 293 | export COMPILER 294 | export CP 295 | export DATA_DIR 296 | export DC 297 | export DF 298 | export DCFLAGS 299 | export DCFLAGS_IMPORT 300 | export DCFLAGS_LINK 301 | export DESTDIR 302 | export DLIB_PATH 303 | export DOC_PATH 304 | export DDOC_PATH 305 | export DYNAMIC_LIB_EXT 306 | export FixPath 307 | export HF 308 | export INCLUDE_DIR 309 | export IMPORT_PATH 310 | export LDCFLAGS 311 | export FPIC 312 | export LIBNAME 313 | export LIB_DIR 314 | export LINKERFLAG 315 | export message 316 | export MAKE 317 | export MKDIR 318 | export MODEL 319 | export MV 320 | export OUTPUT 321 | export OS 322 | export PATH_SEP 323 | export PKG_CONFIG_FILE 324 | export PREFIX 325 | export RANLIB 326 | export RM 327 | export STATIC_LIB_EXT 328 | export SONAME 329 | -------------------------------------------------------------------------------- /dub.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "scid", 3 | "libs": ["lapack","blas"], 4 | "targetType": "library", 5 | "homepage": "https://github.com/DlangScience/scid", 6 | "description": "A collection of numerical routines and bindings", 7 | "copyright": "Copyright (c) 2009-2015, Lars T. Kyllingstad.", 8 | "authors": ["Lars Tandle Kyllingstad"], 9 | "license": "BSL-1.0", 10 | 11 | "buildTypes": { 12 | "DSddox": { 13 | "buildOptions": ["syntaxOnly"], 14 | "dflags": ["-c", "-Df__dummy.html", "-Xfdocs.json"], 15 | "postBuildCommands": [ 16 | "rm -rf site/api", 17 | "ddox filter --min-protection=Protected docs.json", 18 | "ddox generate-html --navigation-type=ModuleTree docs.json site/api", 19 | "rm __dummy.html docs.json" 20 | ] 21 | } 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /site/readme_as_index: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DlangScience/scid/a62271d62926dde9b1018b21bacec595b9df8901/site/readme_as_index -------------------------------------------------------------------------------- /source/scid/constants.d: -------------------------------------------------------------------------------- 1 | /** Various fundamental constants. Physical constants are given in SI units. 2 | 3 | Authors: Lars Tandle Kyllingstad 4 | Copyright: Copyright (c) 2010, Lars T. Kyllingstad. All rights reserved. 5 | License: Boost License 1.0 6 | Macros: 7 | SUB = $0 8 | */ 9 | module scid.constants; 10 | 11 | 12 | 13 | 14 | // ==================== PHYSICAL CONSTANTS ==================== 15 | 16 | /// Boltzmann constant, $(I k$(SUB B)) [J/K] 17 | enum real boltzmannConstant = 1.38064_88e-23L; 18 | 19 | /// Planck constant, ℎ [J s] 20 | enum real planckConstant = 6.62606_896e-34L; 21 | 22 | /// Reduced Planck constant, ℏ ≡ ℎ/2π [J s] 23 | enum real hBar = 1.05457_1628e-34L; 24 | 25 | 26 | 27 | 28 | // ==================== MATHEMATICAL CONSTANTS ==================== 29 | 30 | /// Pi squared, π² 31 | enum real piSquared = 0x9.de9e64df22ef2d2p+0L; 32 | 33 | /// Two times pi, 2π 34 | enum real twoPi = 0xc.90fdaa22168c235p-1L; 35 | 36 | /// Euler-Mascheroni constant, γ 37 | enum real eulerGamma = 0x9.3c467e37db0c7a5p-4L; 38 | 39 | -------------------------------------------------------------------------------- /source/scid/core/fortran.d: -------------------------------------------------------------------------------- 1 | /** Stuff that is useful when porting FORTRAN code to D. 2 | 3 | Authors: Lars Tandle Kyllingstad 4 | Copyright: Copyright (c) 2009–2011, Lars T. Kyllingstad. All rights reserved. 5 | License: Boost License 1.0 6 | */ 7 | module scid.core.fortran; 8 | 9 | 10 | import std.conv; 11 | import std.traits: Unqual; 12 | 13 | 14 | 15 | 16 | /** Wrap a one- or two-dimensional array around the given pointer. 17 | Meant as a substitute for FORTRAN's dimension statement. 18 | */ 19 | FortranArray!T dimension(T)(T* ptr, size_t len) 20 | { 21 | FortranArray!T a; 22 | a._length = len; 23 | a._ptr = ptr; 24 | a._ptrm1 = ptr - 1; 25 | return a; 26 | } 27 | 28 | 29 | /// ditto 30 | FortranArray2D!T dimension(T)(T* ptr, size_t rows, size_t cols) 31 | { 32 | FortranArray2D!T a; 33 | a._length = rows*cols; 34 | a._ptr = ptr; 35 | a._ptrm1 = ptr - 1; 36 | a._rows = rows; 37 | a._cols = cols; 38 | return a; 39 | } 40 | 41 | 42 | 43 | 44 | /** A simple, lightweight, one-dimensional base-1 array. */ 45 | struct FortranArray(T) 46 | { 47 | private: 48 | // By putting _length and _ptr first, this array is binary compatible 49 | // with built-in D arrays. 50 | size_t _length; 51 | T* _ptr; 52 | T* _ptrm1; 53 | 54 | void boundsCheck(size_t i, string file, int line) const 55 | { 56 | assert (i>0 && i<=_length, 57 | file~":"~to!string(line)~":index out of bounds"); 58 | } 59 | 60 | 61 | public: 62 | /// The length of the array. 63 | @property size_t length() const { return _length; } 64 | 65 | 66 | /// A pointer to the first element of the array. 67 | @property T* ptr() { return _ptr; } 68 | 69 | 70 | static if (is(T == const) || is(T == immutable)) 71 | { 72 | Unqual!T opIndex 73 | (string file = __FILE__, int line = __LINE__) 74 | (size_t i) 75 | const 76 | { 77 | boundsCheck(i, file, line); 78 | return _ptrm1[i]; 79 | } 80 | } 81 | else 82 | { 83 | // Workaround for DMD bug 2460 84 | template opIndex(string file = __FILE__, int line = __LINE__) { 85 | ref T opIndex 86 | (size_t i) 87 | { 88 | boundsCheck(i, file, line); 89 | return _ptrm1[i]; 90 | }} 91 | 92 | T opIndexAssign 93 | (string file = __FILE__, int line = __LINE__) 94 | (T value, size_t i) 95 | { 96 | boundsCheck(i, file, line); 97 | return (_ptrm1[i] = value); 98 | } 99 | 100 | T opIndexOpAssign 101 | (string op, string file = __FILE__, int line = __LINE__) 102 | (T value, size_t i) 103 | { 104 | boundsCheck(i, file, line); 105 | mixin("return _ptrm1[i] "~op~"= value;"); 106 | } 107 | } 108 | } 109 | 110 | 111 | unittest 112 | { 113 | int[] a = [1, 2, 3]; 114 | auto b = dimension(a.ptr, 3); 115 | 116 | // Basic functionality 117 | assert (b[3] == a[2]); 118 | b[3] = 5; 119 | assert (b[3] == 5); 120 | b[3] -= 2; 121 | assert (b[3] == 3); 122 | 123 | assert (b.ptr[2] == 3); 124 | 125 | // Binary compatible with D arrays. 126 | int[] d = *(cast(int[]*) &b); 127 | assert (d == a); 128 | 129 | // Works with const and immutable 130 | immutable int[] ia = [1,2,3]; 131 | auto ib = dimension(ia.ptr, 3); 132 | assert (ib[3] == 3); 133 | assert (!__traits(compiles, { ib[3] = 5; })); 134 | 135 | } 136 | 137 | 138 | 139 | 140 | /** A simple, lightweight, two-dimensional base-1 array. */ 141 | struct FortranArray2D(T) 142 | { 143 | private: 144 | // By putting length and ptr first, this array is binary compatible 145 | // with built-in D arrays. 146 | size_t _length; 147 | T* _ptr; 148 | T* _ptrm1; 149 | size_t _rows; 150 | size_t _cols; 151 | 152 | void boundsCheck(size_t i, size_t j, string file, int line) const 153 | { 154 | assert (i>0 && i<=_rows, 155 | file~":"~to!string(line)~":first index out of bounds"); 156 | assert (j>0 && j<=_cols, 157 | file~":"~to!string(line)~":second index out of bounds"); 158 | } 159 | 160 | 161 | public: 162 | /// The number of rows and columns in the array. 163 | @property size_t rows() const { return _rows; } 164 | @property size_t cols() const { return _cols; } /// ditto 165 | 166 | 167 | /// The number of elements in the array. 168 | @property size_t length() const { return _length; } 169 | 170 | 171 | /// A pointer to the first element of the array. 172 | @property T* ptr() { return _ptr; } 173 | 174 | 175 | static if (is(T == const) || is(T == immutable)) 176 | { 177 | Unqual!T opIndex 178 | (string file = __FILE__, int line = __LINE__) 179 | (size_t i, size_t j) 180 | const 181 | { 182 | boundsCheck(i, j, file, line); 183 | return _ptrm1[i + (j-1)*_rows]; 184 | } 185 | } 186 | else 187 | { 188 | // Workaround for DMD bug 2460 189 | template opIndex(string file = __FILE__, int line = __LINE__) { 190 | ref T opIndex 191 | (size_t i, size_t j) 192 | { 193 | boundsCheck(i, j, file, line); 194 | return _ptrm1[i + (j-1)*_rows]; 195 | }} 196 | 197 | T opIndexAssign 198 | (string file = __FILE__, int line = __LINE__) 199 | (T value, size_t i, size_t j) 200 | { 201 | boundsCheck(i, j, file, line); 202 | return (_ptrm1[i + (j-1)*_rows] = value); 203 | } 204 | 205 | T opIndexOpAssign 206 | (string op, string file = __FILE__, int line = __LINE__) 207 | (T value, size_t i, size_t j) 208 | { 209 | boundsCheck(i, j, file, line); 210 | mixin("return _ptrm1[i + (j-1)*_rows] "~op~"= value;"); 211 | } 212 | } 213 | } 214 | 215 | unittest 216 | { 217 | int[] a = [1, 2, 3, 4, 5, 6]; 218 | auto b = dimension(a.ptr, 3, 2); 219 | 220 | // Basic functionality 221 | assert (b[2,2] == a[4]); 222 | b[2,2] = 5; 223 | assert (b[2,2] == 5); 224 | b[2,2] -= 2; 225 | assert (b[2,2] == 3); 226 | 227 | assert (b.ptr[4] == 3); 228 | 229 | // Binary compatible with D arrays. 230 | int[] d = *(cast(int[]*) &b); 231 | assert (d == a); 232 | 233 | // Works with const and immutable 234 | const int[] ia = [1, 2, 3, 4, 5, 6]; 235 | auto ib = dimension(ia.ptr, 3, 2); 236 | assert (ib[2,2] == ia[4]); 237 | assert (!__traits(compiles, { ib[2,2] = 5; })); 238 | } 239 | 240 | 241 | 242 | 243 | /** Convert an unsigned integer to a signed 32-bit integer. 244 | 245 | FORTRAN code typically uses 32-bit signed ints for things 246 | like array lengths. D array lengths, on the other hand, 247 | are uints in 32-bit mode, and ulongs in 64-bit mode. 248 | Use of this function is safer than inserting casts everywhere, 249 | because it checks that the given uint/ulong fits in an int. 250 | For efficiency, this check is disabled in release mode 251 | (which is a good reason to use this function over 252 | std.conv.to!int). 253 | */ 254 | int toInt(size_t u) @safe pure nothrow 255 | { 256 | assert (u <= int.max, "Number doesn't fit in a 32-bit integer"); 257 | return cast(int) u; 258 | } 259 | 260 | 261 | unittest 262 | { 263 | assert (toInt(10uL) == 10); 264 | assert (toInt(10u) == 10); 265 | } 266 | -------------------------------------------------------------------------------- /source/scid/core/meta.d: -------------------------------------------------------------------------------- 1 | /** Facilities for template metaprogramming. 2 | 3 | Authors: Lars Tandle Kyllingstad 4 | Copyright: Copyright (c) 2009–2011, Lars T. Kyllingstad. All rights reserved. 5 | License: Boost License 1.0 6 | */ 7 | module scid.core.meta; 8 | 9 | import std.traits; 10 | import scid.core.traits; 11 | import std.complex: Complex; 12 | 13 | 14 | /** Evaluates to the zero value for a given type. 15 | --- 16 | assert (Zero!creal == 0.0+0.0i); 17 | --- 18 | */ 19 | template Zero(T) 20 | { 21 | static if (isFloatingPoint!T) 22 | enum T Zero = 0.0; 23 | else static if (is(T : Complex!E, E)) 24 | enum T Zero = T(0, 0); 25 | else static if (isComplex!T) 26 | enum T Zero = 0.0 + 0.0i; 27 | else static if (isIntegral!T) 28 | enum T Zero = 0; 29 | else static assert (false, "Zero: Type has no obvious zero: "~T.stringof); 30 | } 31 | 32 | version(unittest) 33 | { 34 | static assert (Zero!creal == 0.0+0.0i); 35 | } 36 | 37 | 38 | 39 | 40 | /** Evaluates to the unit value for a given type. 41 | --- 42 | assert (One!creal = 1.0+0.0i); 43 | --- 44 | */ 45 | template One(T) 46 | { 47 | static if (isFloatingPoint!T) 48 | enum T One = 1.0; 49 | else static if (is(T : Complex!E, E)) 50 | enum T One = T(1, 0); 51 | else static if (isComplex!T) 52 | enum T One = 1.0 + 0.0i; 53 | else static if (isIntegral!T) 54 | enum T One = 1; 55 | else static assert (false, "One: Type has no obvious unit element: " 56 | ~T.stringof); 57 | } 58 | 59 | version(unittest) 60 | { 61 | static assert (One!creal == 1.0+0.0i); 62 | } 63 | -------------------------------------------------------------------------------- /source/scid/core/testing.d: -------------------------------------------------------------------------------- 1 | /** Unit testing tools. 2 | 3 | Authors: Lars Tandle Kyllingstad 4 | Copyright: Copyright (c) 2009–2015, Lars T. Kyllingstad. All rights reserved. 5 | License: Boost License 1.0 6 | */ 7 | module scid.core.testing; 8 | 9 | import scid.core.meta: Zero; 10 | import scid.types; 11 | 12 | 13 | /** This function is used to check a computed value along with 14 | its error estimate. It evaluates to the following: 15 | --- 16 | abs(result-expected) <= absError 17 | && absError <= max(abs(result*relAccuracy), absAccuracy) 18 | --- 19 | */ 20 | bool isAccurate(T)(Result!T result, T expected, T relAccuracy, 21 | T absAccuracy=Zero!T) 22 | { 23 | return isAccurate(result.value, result.error, expected, relAccuracy, 24 | absAccuracy); 25 | } 26 | 27 | /// ditto 28 | bool isAccurate(T)(T result, T absError, T expected, T relAccuracy, 29 | T absAccuracy=Zero!T) 30 | in 31 | { 32 | assert (absError >= 0.0); 33 | assert (relAccuracy >= 0.0); 34 | assert (absAccuracy >= 0.0); 35 | } 36 | body 37 | { 38 | import std.algorithm: max; 39 | import std.math: abs; 40 | return abs(result-expected) <= absError 41 | && absError <= max(abs(result*relAccuracy), absAccuracy); 42 | } 43 | 44 | unittest 45 | { 46 | assert (isAccurate(2.0000001, 0.000001, 2.0, 0.000001)); 47 | } 48 | -------------------------------------------------------------------------------- /source/scid/ports/linpack/gtsl.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/linpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost Licence 1.0 7 | */ 8 | module scid.ports.linpack.gtsl; 9 | 10 | 11 | import std.math: fabs; 12 | 13 | import scid.core.fortran; 14 | 15 | 16 | 17 | 18 | /// 19 | void gtsl(Real)(int n, Real* c_, Real* d_, Real* e_, Real* b_, out int info) 20 | { 21 | auto c = dimension(c_, n); 22 | auto d = dimension(d_, n); 23 | auto e = dimension(e_, n); 24 | auto b = dimension(b_, n); 25 | // 26 | // dgtsl given a general tridiagonal matrix and a right hand 27 | // side will find the solution. 28 | // 29 | // on entry 30 | // 31 | // n integer 32 | // is the order of the tridiagonal matrix. 33 | // 34 | // c double precision(n) 35 | // is the subdiagonal of the tridiagonal matrix. 36 | // c(2) through c(n) should contain the subdiagonal. 37 | // on output c is destroyed. 38 | // 39 | // d double precision(n) 40 | // is the diagonal of the tridiagonal matrix. 41 | // on output d is destroyed. 42 | // 43 | // e double precision(n) 44 | // is the superdiagonal of the tridiagonal matrix. 45 | // e(1) through e(n-1) should contain the superdiagonal. 46 | // on output e is destroyed. 47 | // 48 | // b double precision(n) 49 | // is the right hand side vector. 50 | // 51 | // on return 52 | // 53 | // b is the solution vector. 54 | // 55 | // info integer 56 | // = 0 normal value. 57 | // = k if the k-th element of the diagonal becomes 58 | // exactly zero. the subroutine returns when 59 | // this is detected. 60 | // 61 | // linpack. this version dated 08/14/78 . 62 | // jack dongarra, argonne national laboratory. 63 | // 64 | // no externals 65 | // fortran dabs 66 | // 67 | // internal variables 68 | // 69 | int k=1,kb=1,kp1=1,nm1=1,nm2=1; 70 | Real t; 71 | // begin block permitting ...exits to 100 72 | // 73 | info = 0; 74 | c[1] = d[1]; 75 | nm1 = n - 1; 76 | if (nm1 < 1) goto l40; 77 | d[1] = e[1]; 78 | e[1] = 0.0; 79 | e[n] = 0.0; 80 | // 81 | for (k=1; k<=nm1; k++) { // end: 30 82 | kp1 = k + 1; 83 | // 84 | // find the largest of the two rows 85 | // 86 | if (fabs(c[kp1]) < fabs(c[k])) goto l10; 87 | // 88 | // interchange row 89 | // 90 | t = c[kp1]; 91 | c[kp1] = c[k]; 92 | c[k] = t; 93 | t = d[kp1]; 94 | d[kp1] = d[k]; 95 | d[k] = t; 96 | t = e[kp1]; 97 | e[kp1] = e[k]; 98 | e[k] = t; 99 | t = b[kp1]; 100 | b[kp1] = b[k]; 101 | b[k] = t; 102 | l10: ; 103 | // 104 | // zero elements 105 | // 106 | if (c[k] != 0.0) goto l20; 107 | info = k; 108 | // ............exit 109 | goto l100; 110 | l20: ; 111 | t = -c[kp1]/c[k]; 112 | c[kp1] = d[kp1] + t*d[k]; 113 | d[kp1] = e[kp1] + t*e[k]; 114 | e[kp1] = 0.0; 115 | b[kp1] = b[kp1] + t*b[k]; 116 | l30: ;} 117 | l40: ; 118 | if (c[n] != 0.0) goto l50; 119 | info = n; 120 | goto l90; 121 | l50: ; 122 | // 123 | // back solve 124 | // 125 | nm2 = n - 2; 126 | b[n] = b[n]/c[n]; 127 | if (n == 1) goto l80; 128 | b[nm1] = (b[nm1] - d[nm1]*b[n])/c[nm1]; 129 | if (nm2 < 1) goto l70; 130 | for (kb=1; kb<=nm2; kb++) { // end: 60 131 | k = nm2 - kb + 1; 132 | b[k] = (b[k] - d[k]*b[k+1] - e[k]*b[k+2])/c[k]; 133 | l60: ;} 134 | l70: ; 135 | l80: ; 136 | l90: ; 137 | l100: ; 138 | // 139 | return; 140 | } 141 | 142 | 143 | unittest 144 | { 145 | alias gtsl!float fgtsl; 146 | alias gtsl!double dgtsl; 147 | alias gtsl!real rgtsl; 148 | } 149 | -------------------------------------------------------------------------------- /source/scid/ports/minpack/dogleg.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/minpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost Licence 1.0 7 | */ 8 | module scid.ports.minpack.dogleg; 9 | 10 | 11 | import std.algorithm: max, min; 12 | import std.math; 13 | 14 | import scid.ports.minpack.enorm; 15 | 16 | 17 | 18 | /** Given an m by n matrix A, an n by n nonsingular diagonal matrix D, 19 | an m-vector b, and a positive number delta, the problem is to 20 | determine the convex combination x of the Gauss-Newton and scaled 21 | gradient directions that minimizes (Ax-b) in the least squares 22 | sense, subject to the restriction that the Euclidean norm of Dx 23 | be at most delta. 24 | 25 | This function completes the solution of the problem if it is 26 | provided with the necessary information from the QR factorization 27 | of A. That is, if A=QR, where Q has orthogonal columns and R is 28 | an upper triangular matrix, then dogleg expects the full upper 29 | triangle of R and the first n components of (Q^T)b. 30 | 31 | Params: 32 | n = a positive integer variable set to the order of R. 33 | r = the upper triangular matrix R. 34 | lr = (not documented) 35 | diag = a vector of length n which must contain the diagonal 36 | elements of the matrix D. 37 | qtb = a vector of length n which must contain the first n 38 | elements of the vector (Q^T)b. 39 | delta = a positive variable which specifies an upper bound 40 | on the Euclidean norm of Dx. 41 | x = an output vector of length n which contains the desired 42 | convex combination of the Gauss-Newton direction and 43 | the scaled gradient direction. 44 | wa1 = work array of length n. 45 | wa2 = work array of length n. 46 | */ 47 | void dogleg(Real)(size_t n, Real* r, size_t lr, Real* diag, Real* qtb, 48 | Real delta, Real* x, Real* wa1, Real* wa2) 49 | { 50 | size_t i, j, jj, jp1, k, l; 51 | Real alpha, bnorm, gnorm, qnorm, sgnorm, sum, temp; 52 | enum : Real 53 | { 54 | one = 1.0, 55 | zero = 0.0, 56 | 57 | // epsmch is the machine precision. 58 | epsmch = Real.epsilon 59 | } 60 | 61 | 62 | 63 | // First, calculate the Gauss-Newton direction. 64 | jj = (n*(n+1))/2; 65 | for (k=0; k jp1) 74 | { 75 | for (i=jp1; i= agiant) 56 | { 57 | if (xabs > rdwarf) 58 | { 59 | // Sum for large components. 60 | if (xabs > x1max) 61 | { 62 | s1 = one + s1*((x1max/xabs)^^2); 63 | x1max = xabs; 64 | } 65 | else 66 | { 67 | s1 += (xabs/x1max)^^2; 68 | } 69 | } 70 | else 71 | { 72 | // Sum for small components. 73 | if (xabs > x3max) 74 | { 75 | s3 = one + s3*((x3max/xabs)^^2); 76 | x3max = xabs; 77 | } 78 | else 79 | { 80 | if (xabs != zero) s3 += (xabs/x3max)^^2; 81 | } 82 | } 83 | } 84 | else 85 | { 86 | // Sum for intermediate components. 87 | s2 += xabs*xabs; 88 | } 89 | } 90 | 91 | 92 | // Calculation of norm. 93 | Real result; 94 | if (s1 != zero) 95 | { 96 | result = x1max*sqrt(s1+(s2/x1max)/x1max); 97 | } 98 | else 99 | { 100 | if (s2 != zero) 101 | { 102 | if (s2 >= x3max) 103 | result = sqrt(s2*(one+(x3max/s2)*(x3max*s3))); 104 | else 105 | result = sqrt(x3max*((s2/x3max)+(x3max*s3))); 106 | } 107 | else 108 | { 109 | result = x3max*sqrt(s3); 110 | } 111 | } 112 | 113 | return result; 114 | } 115 | 116 | 117 | unittest 118 | { 119 | double[] v = [ 1.0, 2.0, 3.0 ]; 120 | double norm = enorm(3, v.ptr); 121 | assert (abs(norm-sqrt(14.0)) < 1e-10); 122 | } 123 | 124 | -------------------------------------------------------------------------------- /source/scid/ports/minpack/fdjac1.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/minpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost Licence 1.0 7 | */ 8 | module scid.ports.minpack.fdjac1; 9 | 10 | 11 | private import std.algorithm: max; 12 | private import std.math: abs, sqrt; 13 | 14 | 15 | 16 | /** This subroutine computes a forward-difference approximation 17 | to the n by n Jacobian matrix associated with a specified 18 | problem of n functions in n variables. If the Jacobian has 19 | a banded form, then function evaluations are saved by only 20 | approximating the nonzero terms. 21 | 22 | 23 | Params: 24 | fcn = 25 | the name of the user-supplied function or delegate which 26 | calculates the functions. fcn should be written as follows. 27 | --- 28 | void f(size_t n, real* x, real* fvec, int iflag) 29 | { 30 | // calculate the functions at x and 31 | // return this vector in fvec. 32 | } 33 | --- 34 | The value of iflag should not be changed by fcn unless 35 | the user wants to terminate execution of fdjac1. 36 | In this case set iflag to a negative integer. 37 | 38 | n = 39 | a positive integer input variable set to the number 40 | of functions and variables. 41 | 42 | x = 43 | an input array of length n. 44 | 45 | fvec = 46 | an input array of length n which must contain the 47 | functions evaluated at x. 48 | 49 | fjac = 50 | an output n by n array which contains the 51 | approximation to the Jacobian matrix evaluated at x. 52 | 53 | ldfjac = 54 | a positive integer input variable not less than n 55 | which specifies the leading dimension of the array fjac. 56 | 57 | iflag = 58 | an integer variable which can be used to terminate 59 | the execution of fdjac1. See description of fcn. 60 | 61 | ml = 62 | a nonnegative integer input variable which specifies 63 | the number of subdiagonals within the band of the 64 | Jacobian matrix. If the Jacobian is not banded, set 65 | ml to at least n - 1. 66 | 67 | epsfcn = 68 | an input variable used in determining a suitable 69 | step length for the forward-difference approximation. This 70 | approximation assumes that the relative errors in the 71 | functions are of the order of epsfcn. If epsfcn is less 72 | than the machine precision, it is assumed that the relative 73 | errors in the functions are of the order of the machine 74 | precision. 75 | 76 | mu = 77 | a nonnegative integer input variable which specifies 78 | the number of superdiagonals within the band of the 79 | Jacobian matrix. If the jacobian is not banded, set 80 | mu to at least n - 1. 81 | 82 | wa1 = 83 | work array of length n. 84 | 85 | wa2 = 86 | work array of length n. If ml + mu + 1 is at 87 | least n, then the Jacobian is considered dense, and wa2 is 88 | not referenced. 89 | */ 90 | void fdjac1(Real, Func)(Func fcn, size_t n, Real* x, Real* fvec, 91 | Real* fjac, size_t ldfjac, int iflag, size_t ml, Real epsfcn, 92 | size_t mu, Real* wa1, Real* wa2) 93 | { 94 | size_t i, j, k; 95 | Real temp, h; 96 | 97 | 98 | enum Real zero = 0.0; 99 | 100 | // epsmch is the machine precision. 101 | enum Real epsmch = Real.epsilon; 102 | 103 | 104 | immutable Real eps = sqrt(max(epsfcn, epsmch)); 105 | immutable size_t msum = ml + mu + 1; 106 | 107 | if (msum >= n) 108 | { 109 | // Computation of dense approximate Jacobian. 110 | for (j=0; j= j-mu && i <= j+ml) 154 | fjac[ij] = (wa1[i] - fvec[i])/h; 155 | } 156 | } 157 | } 158 | } 159 | 160 | 161 | unittest 162 | { 163 | void f(size_t n, double* a, double* fvec, ref int iflag) 164 | { 165 | auto x = a[0], y = a[1]; 166 | 167 | fvec[0] = 2.0*x*y; 168 | fvec[1] = x-y; 169 | } 170 | 171 | bool close(double x, double y) 172 | { 173 | return (abs(x-y) < 1e-6); 174 | } 175 | 176 | double[] x = [ 1.0, 2.0 ]; 177 | double[] fx = new double[2]; 178 | double[] j = new double[4]; 179 | double[] w1 = new double[2]; 180 | double[] w2 = new double[2]; 181 | int iflag = 1; 182 | 183 | f(2, x.ptr, fx.ptr, iflag); 184 | fdjac1(&f, 2, x.ptr, fx.ptr, j.ptr, 2, iflag, 2, 1e-8, 2, w1.ptr, w2.ptr); 185 | 186 | assert (close(j[0], 4.0) && close(j[2], 2.0) 187 | && close(j[1], 1.0) && close(j[3], -1.0)); 188 | } 189 | -------------------------------------------------------------------------------- /source/scid/ports/minpack/qform.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/minpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost Licence 1.0 7 | */ 8 | module scid.ports.minpack.qform; 9 | 10 | 11 | private import std.algorithm: min; 12 | 13 | 14 | 15 | 16 | /** This subroutine proceeds from the computed QR factorization of 17 | an m by n matrix a to accumulate the m by m orthogonal matrix 18 | Q from its factored form. 19 | 20 | Params: 21 | m = a positive integer input variable set to the number 22 | of rows of a and the order of q. 23 | n = a positive integer input variable set to the number 24 | of columns of a. 25 | q = an array of length m^2. On input the full lower trapezoid in 26 | the first min(m,n) columns of Q contains the factored form. 27 | on output Q has been accumulated into a square matrix. 28 | ldq = a positive integer input variable not less than m 29 | which specifies the leading dimension of the array q. 30 | wa = a work array of length m. 31 | */ 32 | void qform(Real)(size_t m, size_t n, Real* q, size_t ldq, Real* wa) 33 | { 34 | size_t i, j, k, l; 35 | 36 | enum : Real 37 | { 38 | one = 1.0, 39 | zero = 0.0 40 | } 41 | 42 | 43 | // Zero out upper triangle of Q in the first min(m,n) columns. 44 | size_t minmn = min(m, n); 45 | if (minmn >= 2) 46 | { 47 | for (j=1; j n) 57 | { 58 | for (j=n; j rdiag[kmax]) kmax = k; 114 | 115 | if (kmax != j) 116 | { 117 | for (i=0; i= jp1) 150 | { 151 | for (k=jp1; k 1) 61 | { 62 | size_t nm1 = n - 1; 63 | for (nmj=2; nmj<=n; nmj++) 64 | { 65 | j = n - nmj; 66 | if (abs(v[j]) > one) 67 | { 68 | cos = one/v[j]; 69 | sin = sqrt(one-cos*cos); 70 | } 71 | else 72 | { 73 | sin = v[j]; 74 | cos = sqrt(one-sin*sin); 75 | } 76 | 77 | for (i=0; i one) 92 | { 93 | cos = one/w[j]; 94 | sin = sqrt(one-cos*cos); 95 | } 96 | else 97 | { 98 | sin = w[j]; 99 | cos = sqrt(one-sin*sin); 100 | } 101 | 102 | for (i=0; i 1) 96 | { 97 | for (nmj=2; nmj<=n; nmj++) 98 | { 99 | j = n - nmj; 100 | jj = jj - (m - j); 101 | w[j] = zero; 102 | 103 | if (v[j] != zero) 104 | { 105 | // Determine a Givens rotation which eliminates the 106 | // j-th element of v. 107 | if (abs(v[nm1]) < abs(v[j])) 108 | { 109 | cotan = v[nm1]/v[j]; 110 | sin = p5/sqrt(p25+p25*cotan*cotan); 111 | cos = sin*cotan; 112 | tau = one; 113 | if (abs(cos)*giant > one) tau = one/cos; 114 | } 115 | else 116 | { 117 | tan = v[j]/v[nm1]; 118 | cos = p5/sqrt(p25+p25*tan*tan); 119 | sin = cos*tan; 120 | tau = sin; 121 | } 122 | 123 | 124 | // Apply the transformation to v and store the information 125 | // necessary to recover the Givens rotation. 126 | v[nm1] = sin*v[j] + cos*v[nm1]; 127 | v[j] = tau; 128 | 129 | 130 | // Apply the transformation to S and extend the spike in w. 131 | for (i=j, l=jj; i 1) 150 | { 151 | for (j=0; j one) tau = one/cos; 164 | } 165 | else 166 | { 167 | tan = w[j]/s[jj]; 168 | cos = p5/sqrt(p25+p25*tan*tan); 169 | sin = cos*tan; 170 | tau = sin; 171 | } 172 | 173 | 174 | // Apply the transformation to S and reduce the spike in w. 175 | for (i=j, l=jj; i 0) goto l10; 52 | t = 10.0^^(-ndigit); 53 | // ------------------------------ 54 | // |*** STOPPING CRITERION I ***| 55 | // ------------------------------ 56 | l10: i++; 57 | e = 3*i; 58 | if (dif > t*size) goto l20; 59 | e += 1.0; 60 | goto l30; 61 | // ------------------------------- 62 | // |*** STOPPING CRITERION II ***| 63 | // ------------------------------- 64 | l20: if (i < limit) goto l40; 65 | e += 2.0; 66 | l30: dif = -dif; 67 | i = 0; 68 | l40: size = e; 69 | } 70 | 71 | 72 | unittest 73 | { 74 | alias stopit!float fstopit; 75 | alias stopit!double dstopit; 76 | alias stopit!real rstopit; 77 | } 78 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qags.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qags; 9 | 10 | 11 | import std.conv; 12 | import scid.ports.quadpack.qagse; 13 | 14 | version(unittest) 15 | { 16 | import std.math; 17 | import scid.core.testing; 18 | } 19 | 20 | 21 | 22 | 23 | /// 24 | void qags(Real, Func)(Func f, Real a, Real b, Real epsabs,Real epsrel, 25 | out Real result, out Real abserr, out int neval, out int ier, 26 | int limit, int lenw, out int last, int* iwork, Real* work) 27 | { 28 | //***begin prologue dqags 29 | //***date written 800101 (yymmdd) 30 | //***revision date 830518 (yymmdd) 31 | //***category no. h2a1a1 32 | //***keywords automatic integrator, general-purpose, 33 | // (end-point) singularities, extrapolation, 34 | // globally adaptive 35 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 36 | // de doncker,elise,appl. math. & prog. div. - k.u.leuven 37 | //***purpose the routine calculates an approximation result to a given 38 | // definite integral i = integral of f over (a,b), 39 | // hopefully satisfying following claim for accuracy 40 | // abs(i-result).le.max(epsabs,epsrel*abs(i)). 41 | //***description 42 | // 43 | // computation of a definite integral 44 | // standard fortran subroutine 45 | // double precision version 46 | // 47 | // 48 | // parameters 49 | // on entry 50 | // f - double precision 51 | // function subprogram defining the integrand 52 | // function f(x). the actual name for f needs to be 53 | // declared e x t e r n a l in the driver program. 54 | // 55 | // a - double precision 56 | // lower limit of integration 57 | // 58 | // b - double precision 59 | // upper limit of integration 60 | // 61 | // epsabs - double precision 62 | // absolute accuracy requested 63 | // epsrel - double precision 64 | // relative accuracy requested 65 | // if epsabs.le.0 66 | // and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), 67 | // the routine will end with ier = 6. 68 | // 69 | // on return 70 | // result - double precision 71 | // approximation to the integral 72 | // 73 | // abserr - double precision 74 | // estimate of the modulus of the absolute error, 75 | // which should equal or exceed abs(i-result) 76 | // 77 | // neval - integer 78 | // number of integrand evaluations 79 | // 80 | // ier - integer 81 | // ier = 0 normal and reliable termination of the 82 | // routine. it is assumed that the requested 83 | // accuracy has been achieved. 84 | // ier.gt.0 abnormal termination of the routine 85 | // the estimates for integral and error are 86 | // less reliable. it is assumed that the 87 | // requested accuracy has not been achieved. 88 | // error messages 89 | // ier = 1 maximum number of subdivisions allowed 90 | // has been achieved. one can allow more sub- 91 | // divisions by increasing the value of limit 92 | // (and taking the according dimension 93 | // adjustments into account. however, if 94 | // this yields no improvement it is advised 95 | // to analyze the integrand in order to 96 | // determine the integration difficulties. if 97 | // the position of a local difficulty can be 98 | // determined (e.g. singularity, 99 | // discontinuity within the interval) one 100 | // will probably gain from splitting up the 101 | // interval at this point and calling the 102 | // integrator on the subranges. if possible, 103 | // an appropriate special-purpose integrator 104 | // should be used, which is designed for 105 | // handling the type of difficulty involved. 106 | // = 2 the occurrence of roundoff error is detec- 107 | // ted, which prevents the requested 108 | // tolerance from being achieved. 109 | // the error may be under-estimated. 110 | // = 3 extremely bad integrand behaviour 111 | // occurs at some points of the integration 112 | // interval. 113 | // = 4 the algorithm does not converge. 114 | // roundoff error is detected in the 115 | // extrapolation table. it is presumed that 116 | // the requested tolerance cannot be 117 | // achieved, and that the returned result is 118 | // the best which can be obtained. 119 | // = 5 the integral is probably divergent, or 120 | // slowly convergent. it must be noted that 121 | // divergence can occur with any other value 122 | // of ier. 123 | // = 6 the input is invalid, because 124 | // (epsabs.le.0 and 125 | // epsrel.lt.max(50*rel.mach.acc.,0.5d-28) 126 | // or limit.lt.1 or lenw.lt.limit*4. 127 | // result, abserr, neval, last are set to 128 | // zero.except when limit or lenw is invalid, 129 | // iwork(1), work(limit*2+1) and 130 | // work(limit*3+1) are set to zero, work(1) 131 | // is set to a and work(limit+1) to b. 132 | // 133 | // dimensioning parameters 134 | // limit - integer 135 | // dimensioning parameter for iwork 136 | // limit determines the maximum number of subintervals 137 | // in the partition of the given integration interval 138 | // (a,b), limit.ge.1. 139 | // if limit.lt.1, the routine will end with ier = 6. 140 | // 141 | // lenw - integer 142 | // dimensioning parameter for work 143 | // lenw must be at least limit*4. 144 | // if lenw.lt.limit*4, the routine will end 145 | // with ier = 6. 146 | // 147 | // last - integer 148 | // on return, last equals the number of subintervals 149 | // produced in the subdivision process, detemines the 150 | // number of significant elements actually in the work 151 | // arrays. 152 | // 153 | // work arrays 154 | // iwork - integer 155 | // vector of dimension at least limit, the first k 156 | // elements of which contain pointers 157 | // to the error estimates over the subintervals 158 | // such that work(limit*3+iwork(1)),... , 159 | // work(limit*3+iwork(k)) form a decreasing 160 | // sequence, with k = last if last.le.(limit/2+2), 161 | // and k = limit+1-last otherwise 162 | // 163 | // work - double precision 164 | // vector of dimension at least lenw 165 | // on return 166 | // work(1), ..., work(last) contain the left 167 | // end-points of the subintervals in the 168 | // partition of (a,b), 169 | // work(limit+1), ..., work(limit+last) contain 170 | // the right end-points, 171 | // work(limit*2+1), ..., work(limit*2+last) contain 172 | // the integral approximations over the subintervals, 173 | // work(limit*3+1), ..., work(limit*3+last) 174 | // contain the error estimates. 175 | // 176 | //***references (none) 177 | //***routines called dqagse,xerror 178 | //***end prologue dqags 179 | // 180 | // 181 | int lvl=1,l1=1,l2=1,l3=1; 182 | // 183 | // check validity of limit and lenw. 184 | // 185 | //***first executable statement dqags 186 | ier = 6; 187 | neval = 0; 188 | last = 0; 189 | result = 0.0; 190 | abserr = 0.0; 191 | if(limit < 1 || lenw < limit*4) goto l10; 192 | // 193 | // prepare call for dqagse. 194 | // 195 | l1 = limit; 196 | l2 = limit+l1; 197 | l3 = limit+l2; 198 | // 199 | qagse!(Real,Func)(f,a,b,epsabs,epsrel,limit,result,abserr,neval, 200 | ier,work,work+l1,work+l2,work+l3,iwork,last); 201 | // 202 | // call error handler if necessary. 203 | // 204 | lvl = 0; 205 | l10: if(ier == 6) lvl = 1; 206 | if(ier != 0) 207 | throw new Exception("abnormal return from qags: "~to!string(ier)); 208 | return; 209 | } 210 | 211 | unittest 212 | { 213 | alias qags!(float, float delegate(float)) fqags; 214 | alias qags!(double, double delegate(double)) dqags; 215 | alias qags!(double, double function(double)) dfqags; 216 | alias qags!(real, real delegate(real)) rqags; 217 | } 218 | 219 | unittest 220 | { 221 | double f(double x) { return x<=0.0 ? 0.0 : log(x)/sqrt(x); } 222 | 223 | enum : double 224 | { 225 | a = 0.0, 226 | b = 1.0, 227 | epsabs = 0.0, 228 | epsrel = 1e-10 229 | } 230 | double result, abserr; 231 | int neval, ier; 232 | enum 233 | { 234 | limit = 500, 235 | lenw = 4*limit 236 | } 237 | int last; 238 | 239 | int[limit] iwork; 240 | double[lenw] work; 241 | 242 | qags(&f, a, b, epsabs, epsrel, result, abserr, neval, ier, 243 | limit, lenw, last, iwork.ptr, work.ptr); 244 | 245 | assert (isAccurate(result, abserr, -4.0, epsrel, epsabs)); 246 | } 247 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qawc.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qawc; 9 | 10 | 11 | import std.conv; 12 | import scid.ports.quadpack.qawce; 13 | 14 | version(unittest) 15 | { 16 | import std.math; 17 | import scid.core.testing; 18 | } 19 | 20 | 21 | 22 | 23 | /// 24 | void qawc(Real, Func)(Func f, Real a, Real b, Real c, Real epsabs, Real epsrel, 25 | out Real result, out Real abserr, out int neval, out int ier, int limit, 26 | int lenw, out int last, int* iwork, Real* work) 27 | { 28 | //***begin prologue dqawc 29 | //***date written 800101 (yymmdd) 30 | //***revision date 830518 (yymmdd) 31 | //***category no. h2a2a1,j4 32 | //***keywords automatic integrator, special-purpose, 33 | // cauchy principal value, 34 | // clenshaw-curtis, globally adaptive 35 | //***author piessens,robert ,appl. math. & progr. div. - k.u.leuven 36 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 37 | //***purpose the routine calculates an approximation result to a 38 | // cauchy principal value i = integral of f*w over (a,b) 39 | // (w(x) = 1/((x-c), c.ne.a, c.ne.b), hopefully satisfying 40 | // following claim for accuracy 41 | // abs(i-result).le.max(epsabe,epsrel*abs(i)). 42 | //***description 43 | // 44 | // computation of a cauchy principal value 45 | // standard fortran subroutine 46 | // double precision version 47 | // 48 | // 49 | // parameters 50 | // on entry 51 | // f - double precision 52 | // function subprogram defining the integrand 53 | // function f(x). the actual name for f needs to be 54 | // declared e x t e r n a l in the driver program. 55 | // 56 | // a - double precision 57 | // under limit of integration 58 | // 59 | // b - double precision 60 | // upper limit of integration 61 | // 62 | // c - parameter in the weight function, c.ne.a, c.ne.b. 63 | // if c = a or c = b, the routine will end with 64 | // ier = 6 . 65 | // 66 | // epsabs - double precision 67 | // absolute accuracy requested 68 | // epsrel - double precision 69 | // relative accuracy requested 70 | // if epsabs.le.0 71 | // and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), 72 | // the routine will end with ier = 6. 73 | // 74 | // on return 75 | // result - double precision 76 | // approximation to the integral 77 | // 78 | // abserr - double precision 79 | // estimate or the modulus of the absolute error, 80 | // which should equal or exceed abs(i-result) 81 | // 82 | // neval - integer 83 | // number of integrand evaluations 84 | // 85 | // ier - integer 86 | // ier = 0 normal and reliable termination of the 87 | // routine. it is assumed that the requested 88 | // accuracy has been achieved. 89 | // ier.gt.0 abnormal termination of the routine 90 | // the estimates for integral and error are 91 | // less reliable. it is assumed that the 92 | // requested accuracy has not been achieved. 93 | // error messages 94 | // ier = 1 maximum number of subdivisions allowed 95 | // has been achieved. one can allow more sub- 96 | // divisions by increasing the value of limit 97 | // (and taking the according dimension 98 | // adjustments into account). however, if 99 | // this yields no improvement it is advised 100 | // to analyze the integrand in order to 101 | // determine the integration difficulties. 102 | // if the position of a local difficulty 103 | // can be determined (e.g. singularity, 104 | // discontinuity within the interval) one 105 | // will probably gain from splitting up the 106 | // interval at this point and calling 107 | // appropriate integrators on the subranges. 108 | // = 2 the occurrence of roundoff error is detec- 109 | // ted, which prevents the requested 110 | // tolerance from being achieved. 111 | // = 3 extremely bad integrand behaviour occurs 112 | // at some points of the integration 113 | // interval. 114 | // = 6 the input is invalid, because 115 | // c = a or c = b or 116 | // (epsabs.le.0 and 117 | // epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) 118 | // or limit.lt.1 or lenw.lt.limit*4. 119 | // result, abserr, neval, last are set to 120 | // zero. exept when lenw or limit is invalid, 121 | // iwork(1), work(limit*2+1) and 122 | // work(limit*3+1) are set to zero, work(1) 123 | // is set to a and work(limit+1) to b. 124 | // 125 | // dimensioning parameters 126 | // limit - integer 127 | // dimensioning parameter for iwork 128 | // limit determines the maximum number of subintervals 129 | // in the partition of the given integration interval 130 | // (a,b), limit.ge.1. 131 | // if limit.lt.1, the routine will end with ier = 6. 132 | // 133 | // lenw - integer 134 | // dimensioning parameter for work 135 | // lenw must be at least limit*4. 136 | // if lenw.lt.limit*4, the routine will end with 137 | // ier = 6. 138 | // 139 | // last - integer 140 | // on return, last equals the number of subintervals 141 | // produced in the subdivision process, which 142 | // determines the number of significant elements 143 | // actually in the work arrays. 144 | // 145 | // work arrays 146 | // iwork - integer 147 | // vector of dimension at least limit, the first k 148 | // elements of which contain pointers 149 | // to the error estimates over the subintervals, 150 | // such that work(limit*3+iwork(1)), ... , 151 | // work(limit*3+iwork(k)) form a decreasing 152 | // sequence, with k = last if last.le.(limit/2+2), 153 | // and k = limit+1-last otherwise 154 | // 155 | // work - double precision 156 | // vector of dimension at least lenw 157 | // on return 158 | // work(1), ..., work(last) contain the left 159 | // end points of the subintervals in the 160 | // partition of (a,b), 161 | // work(limit+1), ..., work(limit+last) contain 162 | // the right end points, 163 | // work(limit*2+1), ..., work(limit*2+last) contain 164 | // the integral approximations over the subintervals, 165 | // work(limit*3+1), ..., work(limit*3+last) 166 | // contain the error estimates. 167 | // 168 | //***references (none) 169 | //***routines called dqawce,xerror 170 | //***end prologue dqawc 171 | // 172 | int l1,l2,l3; 173 | // 174 | // check validity of limit and lenw. 175 | // 176 | //***first executable statement dqawc 177 | ier = 6; 178 | neval = 0; 179 | last = 0; 180 | result = 0.0; 181 | abserr = 0.0; 182 | if(limit < 1 || lenw < limit*4) goto l10; 183 | // 184 | // prepare call for dqawce. 185 | // 186 | l1 = limit; 187 | l2 = limit+l1; 188 | l3 = limit+l2; 189 | qawce!(Real, Func)(f,a,b,c,epsabs,epsrel,limit,result,abserr,neval,ier, 190 | work,work+l1,work+l2,work+l3,iwork,last); 191 | // 192 | // call error handler if necessary. 193 | // 194 | l10: if(ier != 0) 195 | throw new Exception("abnormal return from qawc: "~to!string(ier)); 196 | return; 197 | } 198 | 199 | 200 | unittest 201 | { 202 | alias qawc!(float, float delegate(float)) fqawc; 203 | alias qawc!(double, double delegate(double)) dqawc; 204 | alias qawc!(double, double function(double)) dfqawc; 205 | alias qawc!(real, real delegate(real)) rqawc; 206 | } 207 | 208 | 209 | unittest 210 | { 211 | // Integral 17 in the QUADPACK book. 212 | enum : double 213 | { 214 | a = 0, 215 | b = 5, 216 | c = 2, 217 | epsabs = 0, 218 | epsrel = 1e-8, 219 | } 220 | double result, abserr; 221 | int neval, ier, last; 222 | enum limit = 500, lenw = limit*4; 223 | int[limit] iwork; 224 | double[lenw] work; 225 | 226 | foreach (alpha; 0 .. 10) 227 | { 228 | double f(double x) 229 | { 230 | return 2.0^^(-alpha) / ((x-1)^^2 + 4.0^^(-alpha)); 231 | } 232 | 233 | qawc(&f, a, b, c, epsabs, epsrel, 234 | result, abserr, neval, ier, limit, 235 | lenw, last, iwork.ptr, work.ptr); 236 | 237 | double exact = 238 | ( 239 | 2.0^^(-alpha) * log(3.0/2) 240 | - 2.0^^(-alpha-1) * log((16+4.0^^(-alpha))/(1+4.0^^(-alpha))) 241 | - atan(2.0^^(alpha+2)) 242 | - atan(2.0^^alpha) 243 | ) 244 | / (1 + 4.0^^(-alpha)); 245 | 246 | assert (isAccurate(result, abserr, exact, epsrel, epsabs)); 247 | } 248 | } 249 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qaws.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qaws; 9 | 10 | 11 | import std.conv; 12 | import scid.ports.quadpack.qawse; 13 | 14 | version(unittest) 15 | { 16 | import std.math; 17 | import scid.core.testing; 18 | } 19 | 20 | 21 | 22 | 23 | /// 24 | void qaws(Real, Func)(Func f, Real a, Real b, Real alfa, Real beta, 25 | int integr, Real epsabs, Real epsrel, out Real result, out Real abserr, 26 | out int neval, out int ier, int limit, int lenw, out int last, 27 | int* iwork, Real* work) 28 | { 29 | //***begin prologue dqaws 30 | //***date written 800101 (yymmdd) 31 | //***revision date 830518 (yymmdd) 32 | //***category no. h2a2a1 33 | //***keywords automatic integrator, special-purpose, 34 | // algebraico-logarithmic end-point singularities, 35 | // clenshaw-curtis, globally adaptive 36 | //***author piessens,robert,appl. math. & progr. div. -k.u.leuven 37 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 38 | //***purpose the routine calculates an approximation result to a given 39 | // definite integral i = integral of f*w over (a,b), 40 | // (where w shows a singular behaviour at the end points 41 | // see parameter integr). 42 | // hopefully satisfying following claim for accuracy 43 | // abs(i-result).le.max(epsabs,epsrel*abs(i)). 44 | //***description 45 | // 46 | // integration of functions having algebraico-logarithmic 47 | // end point singularities 48 | // standard fortran subroutine 49 | // double precision version 50 | // 51 | // parameters 52 | // on entry 53 | // f - double precision 54 | // function subprogram defining the integrand 55 | // function f(x). the actual name for f needs to be 56 | // declared e x t e r n a l in the driver program. 57 | // 58 | // a - double precision 59 | // lower limit of integration 60 | // 61 | // b - double precision 62 | // upper limit of integration, b.gt.a 63 | // if b.le.a, the routine will end with ier = 6. 64 | // 65 | // alfa - double precision 66 | // parameter in the integrand function, alfa.gt.(-1) 67 | // if alfa.le.(-1), the routine will end with 68 | // ier = 6. 69 | // 70 | // beta - double precision 71 | // parameter in the integrand function, beta.gt.(-1) 72 | // if beta.le.(-1), the routine will end with 73 | // ier = 6. 74 | // 75 | // integr - integer 76 | // indicates which weight function is to be used 77 | // = 1 (x-a)**alfa*(b-x)**beta 78 | // = 2 (x-a)**alfa*(b-x)**beta*log(x-a) 79 | // = 3 (x-a)**alfa*(b-x)**beta*log(b-x) 80 | // = 4 (x-a)**alfa*(b-x)**beta*log(x-a)*log(b-x) 81 | // if integr.lt.1 or integr.gt.4, the routine 82 | // will end with ier = 6. 83 | // 84 | // epsabs - double precision 85 | // absolute accuracy requested 86 | // epsrel - double precision 87 | // relative accuracy requested 88 | // if epsabs.le.0 89 | // and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), 90 | // the routine will end with ier = 6. 91 | // 92 | // on return 93 | // result - double precision 94 | // approximation to the integral 95 | // 96 | // abserr - double precision 97 | // estimate of the modulus of the absolute error, 98 | // which should equal or exceed abs(i-result) 99 | // 100 | // neval - integer 101 | // number of integrand evaluations 102 | // 103 | // ier - integer 104 | // ier = 0 normal and reliable termination of the 105 | // routine. it is assumed that the requested 106 | // accuracy has been achieved. 107 | // ier.gt.0 abnormal termination of the routine 108 | // the estimates for the integral and error 109 | // are less reliable. it is assumed that the 110 | // requested accuracy has not been achieved. 111 | // error messages 112 | // ier = 1 maximum number of subdivisions allowed 113 | // has been achieved. one can allow more 114 | // subdivisions by increasing the value of 115 | // limit (and taking the according dimension 116 | // adjustments into account). however, if 117 | // this yields no improvement it is advised 118 | // to analyze the integrand, in order to 119 | // determine the integration difficulties 120 | // which prevent the requested tolerance from 121 | // being achieved. in case of a jump 122 | // discontinuity or a local singularity 123 | // of algebraico-logarithmic type at one or 124 | // more interior points of the integration 125 | // range, one should proceed by splitting up 126 | // the interval at these points and calling 127 | // the integrator on the subranges. 128 | // = 2 the occurrence of roundoff error is 129 | // detected, which prevents the requested 130 | // tolerance from being achieved. 131 | // = 3 extremely bad integrand behaviour occurs 132 | // at some points of the integration 133 | // interval. 134 | // = 6 the input is invalid, because 135 | // b.le.a or alfa.le.(-1) or beta.le.(-1) or 136 | // or integr.lt.1 or integr.gt.4 or 137 | // (epsabs.le.0 and 138 | // epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) 139 | // or limit.lt.2 or lenw.lt.limit*4. 140 | // result, abserr, neval, last are set to 141 | // zero. except when lenw or limit is invalid 142 | // iwork(1), work(limit*2+1) and 143 | // work(limit*3+1) are set to zero, work(1) 144 | // is set to a and work(limit+1) to b. 145 | // 146 | // dimensioning parameters 147 | // limit - integer 148 | // dimensioning parameter for iwork 149 | // limit determines the maximum number of 150 | // subintervals in the partition of the given 151 | // integration interval (a,b), limit.ge.2. 152 | // if limit.lt.2, the routine will end with ier = 6. 153 | // 154 | // lenw - integer 155 | // dimensioning parameter for work 156 | // lenw must be at least limit*4. 157 | // if lenw.lt.limit*4, the routine will end 158 | // with ier = 6. 159 | // 160 | // last - integer 161 | // on return, last equals the number of 162 | // subintervals produced in the subdivision process, 163 | // which determines the significant number of 164 | // elements actually in the work arrays. 165 | // 166 | // work arrays 167 | // iwork - integer 168 | // vector of dimension limit, the first k 169 | // elements of which contain pointers 170 | // to the error estimates over the subintervals, 171 | // such that work(limit*3+iwork(1)), ..., 172 | // work(limit*3+iwork(k)) form a decreasing 173 | // sequence with k = last if last.le.(limit/2+2), 174 | // and k = limit+1-last otherwise 175 | // 176 | // work - double precision 177 | // vector of dimension lenw 178 | // on return 179 | // work(1), ..., work(last) contain the left 180 | // end points of the subintervals in the 181 | // partition of (a,b), 182 | // work(limit+1), ..., work(limit+last) contain 183 | // the right end points, 184 | // work(limit*2+1), ..., work(limit*2+last) 185 | // contain the integral approximations over 186 | // the subintervals, 187 | // work(limit*3+1), ..., work(limit*3+last) 188 | // contain the error estimates. 189 | // 190 | //***references (none) 191 | //***routines called dqawse,xerror 192 | //***end prologue dqaws 193 | // 194 | int l1,l2,l3; 195 | // 196 | // check validity of limit and lenw. 197 | // 198 | //***first executable statement dqaws 199 | ier = 6; 200 | neval = 0; 201 | last = 0; 202 | result = 0.0; 203 | abserr = 0.0; 204 | if(limit < 2 || lenw < limit*4) goto l10; 205 | // 206 | // prepare call for dqawse. 207 | // 208 | l1 = limit; 209 | l2 = limit+l1; 210 | l3 = limit+l2; 211 | // 212 | qawse!(Real,Func)(f,a,b,alfa,beta,integr,epsabs,epsrel,limit,result, 213 | abserr,neval,ier,work,work+l1,work+l2,work+l3,iwork,last); 214 | // 215 | // call error handler if necessary. 216 | // 217 | l10: if(ier != 0) 218 | throw new Exception("abnormal return from qaws: "~to!string(ier)); 219 | return; 220 | } 221 | 222 | unittest 223 | { 224 | alias qaws!(float, float delegate(float)) fqaws; 225 | alias qaws!(double, double delegate(double)) dqaws; 226 | alias qaws!(double, double function(double)) dfqaws; 227 | alias qaws!(real, real delegate(real)) rqaws; 228 | } 229 | 230 | unittest 231 | { 232 | // From QUADPACK book 233 | double f(double x) 234 | { 235 | if (x <= 0.0) return 0.0; 236 | double logx2 = log(x)^^2; 237 | return (1+logx2)^^(-2.0); 238 | } 239 | 240 | double a = 0.0, b = 1.0, alfa = 0.0, beta = 0.0; 241 | int integr = 2, neval, ier, last; 242 | double epsabs = 0.0, epsrel = 1e-8; 243 | double result, abserr; 244 | enum 245 | { 246 | limit = 500, 247 | lenw = 4*limit 248 | } 249 | 250 | int[limit] iwork; 251 | double[lenw] work; 252 | 253 | qaws(&f, a, b, alfa, beta, integr, epsabs, epsrel, result, abserr, 254 | neval, ier, limit, lenw, last, iwork.ptr, work.ptr); 255 | 256 | double ans = -0.18927518788; 257 | assert (isAccurate(result, abserr, ans, epsrel, epsabs)); 258 | } 259 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qc25c.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qc25c; 9 | 10 | 11 | import std.math: fabs, log; 12 | 13 | import scid.core.fortran; 14 | import scid.ports.quadpack.qcheb; 15 | import scid.ports.quadpack.qk15w; 16 | import scid.ports.quadpack.qwgtc; 17 | 18 | 19 | 20 | 21 | /// 22 | void qc25c(Real, Func)(Func f, Real a, Real b, Real c, out Real result, 23 | out Real abserr, ref int krul, out int neval) 24 | { 25 | //***begin prologue dqc25c 26 | //***date written 810101 (yymmdd) 27 | //***revision date 830518 (yymmdd) 28 | //***category no. h2a2a2,j4 29 | //***keywords 25-point clenshaw-curtis integration 30 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 31 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 32 | //***purpose to compute i = integral of f*w over (a,b) with 33 | // error estimate, where w(x) = 1/(x-c) 34 | //***description 35 | // 36 | // integration rules for the computation of cauchy 37 | // principal value integrals 38 | // standard fortran subroutine 39 | // double precision version 40 | // 41 | // parameters 42 | // f - double precision 43 | // function subprogram defining the integrand function 44 | // f(x). the actual name for f needs to be declared 45 | // e x t e r n a l in the driver program. 46 | // 47 | // a - double precision 48 | // left end point of the integration interval 49 | // 50 | // b - double precision 51 | // right end point of the integration interval, b.gt.a 52 | // 53 | // c - double precision 54 | // parameter in the weight function 55 | // 56 | // result - double precision 57 | // approximation to the integral 58 | // result is computed by using a generalized 59 | // clenshaw-curtis method if c lies within ten percent 60 | // of the integration interval. in the other case the 61 | // 15-point kronrod rule obtained by optimal addition 62 | // of abscissae to the 7-point gauss rule, is applied. 63 | // 64 | // abserr - double precision 65 | // estimate of the modulus of the absolute error, 66 | // which should equal or exceed abs(i-result) 67 | // 68 | // krul - integer 69 | // key which is decreased by 1 if the 15-point 70 | // gauss-kronrod scheme has been used 71 | // 72 | // neval - integer 73 | // number of integrand evaluations 74 | // 75 | //....................................................................... 76 | //***references (none) 77 | //***routines called dqcheb,dqk15w,dqwgtc 78 | //***end prologue dqc25c 79 | // 80 | Real ak22,amom0,amom1,amom2,cc,centr, 81 | hlgth,p2,p3,p4,resabs, 82 | resasc,res12,res24,u; 83 | Real[13] cheb12_; 84 | Real[25] fval_, cheb24_; 85 | int i=1,isym=1,k=1,kp=1; 86 | // 87 | // the vector x contains the values cos(k*pi/24), 88 | // k = 1, ..., 11, to be used for the chebyshev series 89 | // expansion of f 90 | // 91 | static immutable Real[11] x_ = [ 92 | 0.9914448613_7381041114_4557526928_563, 93 | 0.9659258262_8906828674_9743199728_897, 94 | 0.9238795325_1128675612_8183189396_788, 95 | 0.8660254037_8443864676_3723170752_936, 96 | 0.7933533402_9123516457_9776961501_299, 97 | 0.7071067811_8654752440_0844362104_849, 98 | 0.6087614290_0872063941_6097542898_164, 99 | 0.5000000000_0000000000_0000000000_000, 100 | 0.3826834323_6508977172_8459984030_399, 101 | 0.2588190451_0252076234_8898837624_048, 102 | 0.1305261922_2005159154_8406227895_489]; 103 | // 104 | auto x = dimension(x_.ptr, 11); 105 | auto fval = dimension(fval_.ptr, 25); 106 | auto cheb12 = dimension(cheb12_.ptr, 13); 107 | auto cheb24 = dimension(cheb24_.ptr, 25); 108 | // 109 | // list of major variables 110 | // ---------------------- 111 | // fval - value of the function f at the points 112 | // cos(k*pi/24), k = 0, ..., 24 113 | // cheb12 - chebyshev series expansion coefficients, 114 | // for the function f, of degree 12 115 | // cheb24 - chebyshev series expansion coefficients, 116 | // for the function f, of degree 24 117 | // res12 - approximation to the integral corresponding 118 | // to the use of cheb12 119 | // res24 - approximation to the integral corresponding 120 | // to the use of cheb24 121 | // dqwgtc - external function subprogram defining 122 | // the weight function 123 | // hlgth - half-length of the interval 124 | // centr - mid point of the interval 125 | // 126 | // 127 | // check the position of c. 128 | // 129 | //***first executable statement dqc25c 130 | cc = (0.2e1*c-b-a)/(b-a); 131 | if(fabs(cc) < 0.11e1) goto l10; 132 | // 133 | // apply the 15-point gauss-kronrod scheme. 134 | // 135 | krul = krul-1; 136 | qk15w!(Real,Func)(f,&qwgtc!Real,c,p2,p3,p4,kp,a,b,result,abserr, 137 | resabs,resasc); 138 | neval = 15; 139 | if (resasc == abserr) krul = krul+1; 140 | goto l50; 141 | // 142 | // use the generalized clenshaw-curtis method. 143 | // 144 | l10: hlgth = 0.5*(b-a); 145 | centr = 0.5*(b+a); 146 | neval = 25; 147 | fval[1] = 0.5*f(hlgth+centr); 148 | fval[13] = f(centr); 149 | fval[25] = 0.5*f(centr-hlgth); 150 | for (i=2; i<=12; i++) { //do 20 i=2,12 151 | u = hlgth*x[i-1]; 152 | isym = 26-i; 153 | fval[i] = f(u+centr); 154 | fval[isym] = f(centr-u); 155 | l20: ;} 156 | // 157 | // compute the chebyshev series expansion. 158 | // 159 | qcheb!Real(x.ptr,fval.ptr,cheb12.ptr,cheb24.ptr); 160 | // 161 | // the modified chebyshev moments are computed by forward 162 | // recursion, using amom0 and amom1 as starting values. 163 | // 164 | amom0 = log(fabs((0.1e1-cc)/(0.1e1+cc))); 165 | amom1 = 0.2e1+cc*amom0; 166 | res12 = cheb12[1]*amom0+cheb12[2]*amom1; 167 | res24 = cheb24[1]*amom0+cheb24[2]*amom1; 168 | for (k=3; k<=13; k++) { //do 30 k=3,13 169 | amom2 = 0.2e1*cc*amom1-amom0; 170 | ak22 = (k-2)*(k-2); 171 | if((k/2)*2 == k) amom2 = amom2-0.4e1/(ak22-0.1e1); 172 | res12 = res12+cheb12[k]*amom2; 173 | res24 = res24+cheb24[k]*amom2; 174 | amom0 = amom1; 175 | amom1 = amom2; 176 | l30: ;} 177 | for (k=14; k<=25; k++) { //do 40 k=14,25 178 | amom2 = 0.2e1*cc*amom1-amom0; 179 | ak22 = (k-2)*(k-2); 180 | if((k/2)*2 == k) amom2 = amom2-0.4e1/(ak22-0.1e1); 181 | res24 = res24+cheb24[k]*amom2; 182 | amom0 = amom1; 183 | amom1 = amom2; 184 | l40: ;} 185 | result = res24; 186 | abserr = fabs(res24-res12); 187 | l50: return; 188 | } 189 | 190 | 191 | unittest 192 | { 193 | alias qc25c!(float, float delegate(float)) fqc25c; 194 | alias qc25c!(double, double delegate(double)) dqc25c; 195 | alias qc25c!(double, double function(double)) dfqc25c; 196 | alias qc25c!(real, real delegate(real)) rqc25c; 197 | } 198 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qcheb.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qcheb; 9 | 10 | 11 | import scid.core.fortran; 12 | 13 | 14 | 15 | 16 | /// 17 | void qcheb(Real)(const Real* x_, Real* fval_, Real* cheb12_, Real* cheb24_) 18 | { 19 | //***begin prologue dqcheb 20 | //***refer to dqc25c,dqc25f,dqc25s 21 | //***routines called (none) 22 | //***revision date 830518 (yymmdd) 23 | //***keywords chebyshev series expansion, fast fourier transform 24 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 25 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 26 | //***purpose this routine computes the chebyshev series expansion 27 | // of degrees 12 and 24 of a function using a 28 | // fast fourier transform method 29 | // f(x) = sum(k=1,..,13) (cheb12(k)*t(k-1,x)), 30 | // f(x) = sum(k=1,..,25) (cheb24(k)*t(k-1,x)), 31 | // where t(k,x) is the chebyshev polynomial of degree k. 32 | //***description 33 | // 34 | // chebyshev series expansion 35 | // standard fortran subroutine 36 | // double precision version 37 | // 38 | // parameters 39 | // on entry 40 | // x - double precision 41 | // vector of dimension 11 containing the 42 | // values cos(k*pi/24), k = 1, ..., 11 43 | // 44 | // fval - double precision 45 | // vector of dimension 25 containing the 46 | // function values at the points 47 | // (b+a+(b-a)*cos(k*pi/24))/2, k = 0, ...,24, 48 | // where (a,b) is the approximation interval. 49 | // fval(1) and fval(25) are divided by two 50 | // (these values are destroyed at output). 51 | // 52 | // on return 53 | // cheb12 - double precision 54 | // vector of dimension 13 containing the 55 | // chebyshev coefficients for degree 12 56 | // 57 | // cheb24 - double precision 58 | // vector of dimension 25 containing the 59 | // chebyshev coefficients for degree 24 60 | // 61 | //***end prologue dqcheb 62 | // 63 | Real alam,alam1,alam2,part1,part2, part3; 64 | Real[12] v_; 65 | int i=1,j=1; 66 | // 67 | auto cheb12 = dimension(cheb12_, 13); 68 | auto cheb24 = dimension(cheb24_, 25); 69 | auto fval = dimension(fval_, 25); 70 | auto v = dimension(v_.ptr, 12); 71 | auto x = dimension(x_, 11); 72 | // 73 | //***first executable statement dqcheb 74 | for (i=1; i<=12; i++) { // end: 10 75 | j = 26-i; 76 | v[i] = fval[i]-fval[j]; 77 | fval[i] = fval[i]+fval[j]; 78 | l10: ;} 79 | alam1 = v[1]-v[9]; 80 | alam2 = x[6]*(v[3]-v[7]-v[11]); 81 | cheb12[4] = alam1+alam2; 82 | cheb12[10] = alam1-alam2; 83 | alam1 = v[2]-v[8]-v[10]; 84 | alam2 = v[4]-v[6]-v[12]; 85 | alam = x[3]*alam1+x[9]*alam2; 86 | cheb24[4] = cheb12[4]+alam; 87 | cheb24[22] = cheb12[4]-alam; 88 | alam = x[9]*alam1-x[3]*alam2; 89 | cheb24[10] = cheb12[10]+alam; 90 | cheb24[16] = cheb12[10]-alam; 91 | part1 = x[4]*v[5]; 92 | part2 = x[8]*v[9]; 93 | part3 = x[6]*v[7]; 94 | alam1 = v[1]+part1+part2; 95 | alam2 = x[2]*v[3]+part3+x[10]*v[11]; 96 | cheb12[2] = alam1+alam2; 97 | cheb12[12] = alam1-alam2; 98 | alam = x[1]*v[2]+x[3]*v[4]+x[5]*v[6]+x[7]*v[8] 99 | +x[9]*v[10]+x[11]*v[12]; 100 | cheb24[2] = cheb12[2]+alam; 101 | cheb24[24] = cheb12[2]-alam; 102 | alam = x[11]*v[2]-x[9]*v[4]+x[7]*v[6]-x[5]*v[8] 103 | +x[3]*v[10]-x[1]*v[12]; 104 | cheb24[12] = cheb12[12]+alam; 105 | cheb24[14] = cheb12[12]-alam; 106 | alam1 = v[1]-part1+part2; 107 | alam2 = x[10]*v[3]-part3+x[2]*v[11]; 108 | cheb12[6] = alam1+alam2; 109 | cheb12[8] = alam1-alam2; 110 | alam = x[5]*v[2]-x[9]*v[4]-x[1]*v[6] 111 | -x[11]*v[8]+x[3]*v[10]+x[7]*v[12]; 112 | cheb24[6] = cheb12[6]+alam; 113 | cheb24[20] = cheb12[6]-alam; 114 | alam = x[7]*v[2]-x[3]*v[4]-x[11]*v[6]+x[1]*v[8] 115 | -x[9]*v[10]-x[5]*v[12]; 116 | cheb24[8] = cheb12[8]+alam; 117 | cheb24[18] = cheb12[8]-alam; 118 | for (i=1; i<=6; i++) { // end: 20 119 | j = 14-i; 120 | v[i] = fval[i]-fval[j]; 121 | fval[i] = fval[i]+fval[j]; 122 | l20: ;} 123 | alam1 = v[1]+x[8]*v[5]; 124 | alam2 = x[4]*v[3]; 125 | cheb12[3] = alam1+alam2; 126 | cheb12[11] = alam1-alam2; 127 | cheb12[7] = v[1]-v[5]; 128 | alam = x[2]*v[2]+x[6]*v[4]+x[10]*v[6]; 129 | cheb24[3] = cheb12[3]+alam; 130 | cheb24[23] = cheb12[3]-alam; 131 | alam = x[6]*(v[2]-v[4]-v[6]); 132 | cheb24[7] = cheb12[7]+alam; 133 | cheb24[19] = cheb12[7]-alam; 134 | alam = x[10]*v[2]-x[6]*v[4]+x[2]*v[6]; 135 | cheb24[11] = cheb12[11]+alam; 136 | cheb24[15] = cheb12[11]-alam; 137 | for (i=1; i<=3; i++) { // end: 30 138 | j = 8-i; 139 | v[i] = fval[i]-fval[j]; 140 | fval[i] = fval[i]+fval[j]; 141 | l30: ;} 142 | cheb12[5] = v[1]+x[8]*v[3]; 143 | cheb12[9] = fval[1]-x[8]*fval[3]; 144 | alam = x[4]*v[2]; 145 | cheb24[5] = cheb12[5]+alam; 146 | cheb24[21] = cheb12[5]-alam; 147 | alam = x[8]*fval[2]-fval[4]; 148 | cheb24[9] = cheb12[9]+alam; 149 | cheb24[17] = cheb12[9]-alam; 150 | cheb12[1] = fval[1]+fval[3]; 151 | alam = fval[2]+fval[4]; 152 | cheb24[1] = cheb12[1]+alam; 153 | cheb24[25] = cheb12[1]-alam; 154 | cheb12[13] = v[1]-v[3]; 155 | cheb24[13] = cheb12[13]; 156 | alam = 0.1e1/0.6e1; 157 | for(i=2; i<=12; i++) { // end: 40 158 | cheb12[i] = cheb12[i]*alam; 159 | l40: ;} 160 | alam = 0.5*alam; 161 | cheb12[1] = cheb12[1]*alam; 162 | cheb12[13] = cheb12[13]*alam; 163 | for (i=2; i<=24; i++) { // end: 50 164 | cheb24[i] = cheb24[i]*alam; 165 | l50: ;} 166 | cheb24[1] = 0.5*alam*cheb24[1]; 167 | cheb24[25] = 0.5*alam*cheb24[25]; 168 | return; 169 | } 170 | 171 | 172 | unittest 173 | { 174 | alias qcheb!float fqcheb; 175 | alias qcheb!double dqcheb; 176 | alias qcheb!real rqcheb; 177 | } 178 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qelg.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qelg; 9 | 10 | 11 | import std.algorithm: min, max; 12 | import std.math; 13 | 14 | import scid.core.fortran; 15 | 16 | 17 | 18 | 19 | /// 20 | void qelg(Real)(ref int n, Real* epstab_, ref Real result, 21 | ref Real abserr, Real* res3la_, ref int nres) 22 | { 23 | //***begin prologue dqelg 24 | //***refer to dqagie,dqagoe,dqagpe,dqagse 25 | //***routines called d1mach 26 | //***revision date 830518 (yymmdd) 27 | //***keywords epsilon algorithm, convergence acceleration, 28 | // extrapolation 29 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 30 | // de doncker,elise,appl. math & progr. div. - k.u.leuven 31 | //***purpose the routine determines the limit of a given sequence of 32 | // approximations, by means of the epsilon algorithm of 33 | // p.wynn. an estimate of the absolute error is also given. 34 | // the condensed epsilon table is computed. only those 35 | // elements needed for the computation of the next diagonal 36 | // are preserved. 37 | //***description 38 | // 39 | // epsilon algorithm 40 | // standard fortran subroutine 41 | // double precision version 42 | // 43 | // parameters 44 | // n - integer 45 | // epstab(n) contains the new element in the 46 | // first column of the epsilon table. 47 | // 48 | // epstab - double precision 49 | // vector of dimension 52 containing the elements 50 | // of the two lower diagonals of the triangular 51 | // epsilon table. the elements are numbered 52 | // starting at the right-hand corner of the 53 | // triangle. 54 | // 55 | // result - double precision 56 | // resulting approximation to the integral 57 | // 58 | // abserr - double precision 59 | // estimate of the absolute error computed from 60 | // result and the 3 previous results 61 | // 62 | // res3la - double precision 63 | // vector of dimension 3 containing the last 3 64 | // results 65 | // 66 | // nres - integer 67 | // number of calls to the routine 68 | // (should be zero at first call) 69 | // 70 | //***end prologue dqelg 71 | // 72 | Real delta1,delta2,delta3, 73 | epmach,epsinf,error,err1,err2,err3,e0,e1,e1abs,e2,e3, 74 | oflow,res,ss,tol1,tol2,tol3; 75 | int i=1,ib=1,ib2=1,ie=1,indx=1,k1=1,k2=1,k3=1,limexp=1,newelm=1,num=1; 76 | auto epstab = dimension(epstab_, 52); 77 | auto res3la = dimension(res3la_, 3); 78 | // 79 | // list of major variables 80 | // ----------------------- 81 | // 82 | // e0 - the 4 elements on which the computation of a new 83 | // e1 element in the epsilon table is based 84 | // e2 85 | // e3 e0 86 | // e3 e1 new 87 | // e2 88 | // newelm - number of elements to be computed in the new 89 | // diagonal 90 | // error - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2) 91 | // result - the element in the new diagonal with least value 92 | // of error 93 | // 94 | // machine dependent constants 95 | // --------------------------- 96 | // 97 | // epmach is the largest relative spacing. 98 | // oflow is the largest positive magnitude. 99 | // limexp is the maximum number of elements the epsilon 100 | // table can contain. if this number is reached, the upper 101 | // diagonal of the epsilon table is deleted. 102 | // 103 | //***first executable statement dqelg 104 | epmach = Real.epsilon; 105 | oflow = Real.max; 106 | nres = nres+1; 107 | abserr = oflow; 108 | result = epstab[n]; 109 | if (n < 3) goto l100; 110 | limexp = 50; 111 | epstab[n+2] = epstab[n]; 112 | newelm = (n-1)/2; 113 | epstab[n] = oflow; 114 | num = n; 115 | k1 = n; 116 | for (i=1; i<=newelm; i++) { // end: l40 117 | k2 = k1-1; 118 | k3 = k1-2; 119 | res = epstab[k1+2]; 120 | e0 = epstab[k3]; 121 | e1 = epstab[k2]; 122 | e2 = res; 123 | e1abs = fabs(e1); 124 | delta2 = e2-e1; 125 | err2 = fabs(delta2); 126 | tol2 = max(fabs(e2),e1abs)*epmach; 127 | delta3 = e1-e0; 128 | err3 = fabs(delta3); 129 | tol3 = max(e1abs,fabs(e0))*epmach; 130 | if (err2 > tol2 || err3 > tol3) goto l10; 131 | // 132 | // if e0, e1 and e2 are equal to within machine 133 | // accuracy, convergence is assumed. 134 | // result = e2 135 | // abserr = abs(e1-e0)+abs(e2-e1) 136 | // 137 | result = res; 138 | abserr = err2+err3; 139 | // ***jump out of do-loop 140 | goto l100; 141 | l10: e3 = epstab[k1]; 142 | epstab[k1] = e1; 143 | delta1 = e1-e3; 144 | err1 = fabs(delta1); 145 | tol1 = max(e1abs,fabs(e3))*epmach; 146 | // 147 | // if two elements are very close to each other, omit 148 | // a part of the table by adjusting the value of n 149 | // 150 | if (err1 <= tol1 || err2 <= tol2 || err3 <= tol3) goto l20; 151 | ss = 0.1e1/delta1+0.1e1/delta2-0.1e1/delta3; 152 | epsinf = fabs(ss*e1); 153 | // 154 | // test to detect irregular behaviour in the table, and 155 | // eventually omit a part of the table adjusting the value 156 | // of n. 157 | // 158 | if(epsinf > 0.1e-3) goto l30; 159 | l20: n = i+i-1; 160 | // ***jump out of do-loop 161 | goto l50; 162 | // 163 | // compute a new element and eventually adjust 164 | // the value of result. 165 | // 166 | l30: res = e1+0.1e1/ss; 167 | epstab[k1] = res; 168 | k1 = k1-2; 169 | error = err2+fabs(res-e2)+err3; 170 | if (error > abserr) goto l40; 171 | abserr = error; 172 | result = res; 173 | l40:;} 174 | // 175 | // shift the table. 176 | // 177 | l50: if (n == limexp) n = 2*(limexp/2)-1; 178 | ib = 1; 179 | if ((num/2)*2 == num) ib = 2; 180 | ie = newelm+1; 181 | for (i=1; i<=ie; i++) { // end: l60 182 | ib2 = ib+2; 183 | epstab[ib] = epstab[ib2]; 184 | ib = ib2; 185 | l60:;} 186 | if (num == n) goto l80; 187 | indx = num-n+1; 188 | for (i=1; i<=n; i++) { // end: l70 189 | epstab[i]= epstab[indx]; 190 | indx = indx+1; 191 | l70:;} 192 | l80: if (nres >= 4) goto l90; 193 | res3la[nres] = result; 194 | abserr = oflow; 195 | goto l100; 196 | // 197 | // compute error estimate 198 | // 199 | l90: abserr = fabs(result-res3la[3])+fabs(result-res3la[2]) 200 | +fabs(result-res3la[1]); 201 | res3la[1] = res3la[2]; 202 | res3la[2] = res3la[3]; 203 | res3la[3] = result; 204 | l100: abserr = max(abserr, 0.5e1*epmach*fabs(result)); 205 | return; 206 | } 207 | 208 | 209 | unittest 210 | { 211 | alias qelg!float fqelg; 212 | alias qelg!double dqelg; 213 | alias qelg!real rqelg; 214 | } 215 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qk15.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | // An idiomatic D port can be found in scid.internal.calculus.integrate_qk. 4 | 5 | /** Authors: Lars Tandle Kyllingstad 6 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 7 | License: Boost License 1.0 8 | */ 9 | module scid.ports.quadpack.qk15; 10 | 11 | 12 | import std.algorithm: max, min; 13 | import std.math; 14 | 15 | import scid.core.fortran; 16 | 17 | 18 | 19 | 20 | /// 21 | void qk15(Real, Func)(Func f, Real a, Real b, out Real result, out Real abserr, 22 | out Real resabs, out Real resasc) 23 | { 24 | //***begin prologue dqk15 25 | //***date written 800101 (yymmdd) 26 | //***revision date 830518 (yymmdd) 27 | //***category no. h2a1a2 28 | //***keywords 15-point gauss-kronrod rules 29 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 30 | // de doncker,elise,appl. math. & progr. div - k.u.leuven 31 | //***purpose to compute i = integral of f over (a,b), with error 32 | // estimate 33 | // j = integral of abs(f) over (a,b) 34 | //***description 35 | // 36 | // integration rules 37 | // standard fortran subroutine 38 | // double precision version 39 | // 40 | // parameters 41 | // on entry 42 | // f - double precision 43 | // function subprogram defining the integrand 44 | // function f(x). the actual name for f needs to be 45 | // declared e x t e r n a l in the calling program. 46 | // 47 | // a - double precision 48 | // lower limit of integration 49 | // 50 | // b - double precision 51 | // upper limit of integration 52 | // 53 | // on return 54 | // result - double precision 55 | // approximation to the integral i 56 | // result is computed by applying the 15-point 57 | // kronrod rule (resk) obtained by optimal addition 58 | // of abscissae to the7-point gauss rule(resg). 59 | // 60 | // abserr - double precision 61 | // estimate of the modulus of the absolute error, 62 | // which should not exceed abs(i-result) 63 | // 64 | // resabs - double precision 65 | // approximation to the integral j 66 | // 67 | // resasc - double precision 68 | // approximation to the integral of abs(f-i/(b-a)) 69 | // over (a,b) 70 | // 71 | //***references (none) 72 | //***routines called d1mach 73 | //***end prologue dqk15 74 | // 75 | Real absc,centr,dhlgth, 76 | epmach,fc,fsum,fval1,fval2,hlgth, 77 | resg,resk,reskh,uflow; 78 | Real[7] fv1_, fv2_; 79 | int j=1,jtw=1,jtwm1=1; 80 | // 81 | // the abscissae and weights are given for the interval (-1,1). 82 | // because of symmetry only the positive abscissae and their 83 | // corresponding weights are given. 84 | // 85 | // xgk - abscissae of the 15-point kronrod rule 86 | // xgk(2), xgk(4), ... abscissae of the 7-point 87 | // gauss rule 88 | // xgk(1), xgk(3), ... abscissae which are optimally 89 | // added to the 7-point gauss rule 90 | // 91 | // wgk - weights of the 15-point kronrod rule 92 | // 93 | // wg - weights of the 7-point gauss rule 94 | // 95 | // 96 | // gauss quadrature weights and kronron quadrature abscissae and weights 97 | // as evaluated with 80 decimal digit arithmetic by l. w. fullerton, 98 | // bell labs, nov. 1981. 99 | // 100 | static immutable Real[4] wg_ = [ 101 | 0.1294849661_6886969327_0611432679_082, 102 | 0.2797053914_8927666790_1467771423_780, 103 | 0.3818300505_0511894495_0369775488_975, 104 | 0.4179591836_7346938775_5102040816_327]; 105 | // 106 | static immutable Real[8] xgk_ = [ 107 | 0.9914553711_2081263920_6854697526_329, 108 | 0.9491079123_4275852452_6189684047_851, 109 | 0.8648644233_5976907278_9712788640_926, 110 | 0.7415311855_9939443986_3864773280_788, 111 | 0.5860872354_6769113029_4144838258_730, 112 | 0.4058451513_7739716690_6606412076_961, 113 | 0.2077849550_0789846760_0689403773_245, 114 | 0.0000000000_0000000000_0000000000_000]; 115 | // 116 | static immutable Real[8] wgk_ = [ 117 | 0.0229353220_1052922496_3732008058_970, 118 | 0.0630920926_2997855329_0700663189_204, 119 | 0.1047900103_2225018383_9876322541_518, 120 | 0.1406532597_1552591874_5189590510_238, 121 | 0.1690047266_3926790282_6583426598_550, 122 | 0.1903505780_6478540991_3256402421_014, 123 | 0.2044329400_7529889241_4161999234_649, 124 | 0.2094821410_8472782801_2999174891_714]; 125 | // 126 | auto fv1 = dimension(fv1_.ptr, 7); 127 | auto fv2 = dimension(fv2_.ptr, 7); 128 | auto wg = dimension(wg_.ptr, 4); 129 | auto wgk = dimension(wgk_.ptr, 8); 130 | auto xgk = dimension(xgk_.ptr, 8); 131 | // 132 | // 133 | // list of major variables 134 | // ----------------------- 135 | // 136 | // centr - mid point of the interval 137 | // hlgth - half-length of the interval 138 | // absc - abscissa 139 | // fval* - function value 140 | // resg - result of the 7-point gauss formula 141 | // resk - result of the 15-point kronrod formula 142 | // reskh - approximation to the mean value of f over (a,b), 143 | // i.e. to i/(b-a) 144 | // 145 | // machine dependent constants 146 | // --------------------------- 147 | // 148 | // epmach is the largest relative spacing. 149 | // uflow is the smallest positive magnitude. 150 | // 151 | //***first executable statement dqk15 152 | epmach = Real.epsilon; 153 | uflow = Real.min_normal; 154 | // 155 | centr = 0.5*(a+b); 156 | hlgth = 0.5*(b-a); 157 | dhlgth = fabs(hlgth); 158 | // 159 | // compute the 15-point kronrod approximation to 160 | // the integral, and estimate the absolute error. 161 | // 162 | fc = f(centr); 163 | resg = fc*wg[4]; 164 | resk = fc*wgk[8]; 165 | resabs = fabs(resk); 166 | for (j=1; j<=3; j++) { //do 10 j=1,3 167 | jtw = j*2; 168 | absc = hlgth*xgk[jtw]; 169 | fval1 = f(centr-absc); 170 | fval2 = f(centr+absc); 171 | fv1[jtw] = fval1; 172 | fv2[jtw] = fval2; 173 | fsum = fval1+fval2; 174 | resg = resg+wg[j]*fsum; 175 | resk = resk+wgk[jtw]*fsum; 176 | resabs = resabs+wgk[jtw]*(fabs(fval1)+fabs(fval2)); 177 | l10: ;} 178 | for (j=1; j<=4; j++) { //do 15 j = 1,4 179 | jtwm1 = j*2-1; 180 | absc = hlgth*xgk[jtwm1]; 181 | fval1 = f(centr-absc); 182 | fval2 = f(centr+absc); 183 | fv1[jtwm1] = fval1; 184 | fv2[jtwm1] = fval2; 185 | fsum = fval1+fval2; 186 | resk = resk+wgk[jtwm1]*fsum; 187 | resabs = resabs+wgk[jtwm1]*(fabs(fval1)+fabs(fval2)); 188 | l15: ;} 189 | reskh = resk*0.5; 190 | resasc = wgk[8]*fabs(fc-reskh); 191 | for (j=1; j<=7; j++) { //do 20 j=1,7 192 | resasc = resasc+wgk[j]*(fabs(fv1[j]-reskh)+fabs(fv2[j]-reskh)); 193 | l20: ;} 194 | result = resk*hlgth; 195 | resabs = resabs*dhlgth; 196 | resasc = resasc*dhlgth; 197 | abserr = fabs((resk-resg)*hlgth); 198 | if(resasc != 0.0 && abserr != 0.0) 199 | abserr = resasc*min(0.1e1,((cast(Real)0.2e3)*abserr/resasc)^^(cast(Real)1.5)); 200 | if(resabs > uflow/(0.5e2*epmach)) abserr = max 201 | ((epmach*0.5e2)*resabs,abserr); 202 | return; 203 | } 204 | 205 | version(unittest) import scid.core.testing; 206 | unittest 207 | { 208 | alias qk15!(float, float delegate(float)) fqk15; 209 | alias qk15!(double, double delegate(double)) dqk15; 210 | alias qk15!(double, double function(double)) dfqk15; 211 | alias qk15!(real, real delegate(real)) rqk15; 212 | 213 | double f(double x) { return x^^3; } 214 | double result, abserr, resabs, resasc; 215 | qk15(&f, 0.0, 1.0, result, abserr, resabs, resasc); 216 | assert (isAccurate(result, abserr, 0.25, 1e-6)); 217 | } 218 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qk15i.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qk15i; 9 | 10 | 11 | import std.algorithm: max, min; 12 | import std.math; 13 | 14 | import scid.core.fortran; 15 | import scid.core.meta; 16 | 17 | 18 | 19 | 20 | /// 21 | void qk15i(Real, Func)(Func f, Real boun, int inf, Real a, Real b, 22 | out Real result, out Real abserr, out Real resabs, out Real resasc) 23 | { 24 | //***begin prologue dqk15i 25 | //***date written 800101 (yymmdd) 26 | //***revision date 830518 (yymmdd) 27 | //***category no. h2a3a2,h2a4a2 28 | //***keywords 15-point transformed gauss-kronrod rules 29 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 30 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 31 | //***purpose the original (infinite integration range is mapped 32 | // onto the interval (0,1) and (a,b) is a part of (0,1). 33 | // it is the purpose to compute 34 | // i = integral of transformed integrand over (a,b), 35 | // j = integral of abs(transformed integrand) over (a,b). 36 | //***description 37 | // 38 | // integration rule 39 | // standard fortran subroutine 40 | // double precision version 41 | // 42 | // parameters 43 | // on entry 44 | // f - double precision 45 | // fuction subprogram defining the integrand 46 | // function f(x). the actual name for f needs to be 47 | // declared e x t e r n a l in the calling program. 48 | // 49 | // boun - double precision 50 | // finite bound of original integration 51 | // range (set to zero if inf = +2) 52 | // 53 | // inf - integer 54 | // if inf = -1, the original interval is 55 | // (-infinity,bound), 56 | // if inf = +1, the original interval is 57 | // (bound,+infinity), 58 | // if inf = +2, the original interval is 59 | // (-infinity,+infinity) and 60 | // the integral is computed as the sum of two 61 | // integrals, one over (-infinity,0) and one over 62 | // (0,+infinity). 63 | // 64 | // a - double precision 65 | // lower limit for integration over subrange 66 | // of (0,1) 67 | // 68 | // b - double precision 69 | // upper limit for integration over subrange 70 | // of (0,1) 71 | // 72 | // on return 73 | // result - double precision 74 | // approximation to the integral i 75 | // result is computed by applying the 15-point 76 | // kronrod rule(resk) obtained by optimal addition 77 | // of abscissae to the 7-point gauss rule(resg). 78 | // 79 | // abserr - double precision 80 | // estimate of the modulus of the absolute error, 81 | // which should equal or exceed abs(i-result) 82 | // 83 | // resabs - double precision 84 | // approximation to the integral j 85 | // 86 | // resasc - double precision 87 | // approximation to the integral of 88 | // abs((transformed integrand)-i/(b-a)) over (a,b) 89 | // 90 | //***references (none) 91 | //***routines called d1mach 92 | //***end prologue dqk15i 93 | // 94 | Real absc,absc1,absc2,centr,dabs,dinf, 95 | epmach,fc,fsum,fval1,fval2,hlgth, 96 | resg,resk,reskh,tabsc1,tabsc2,uflow; 97 | Real[7] fv1_, fv2_; 98 | int j; 99 | // 100 | // the abscissae and weights are supplied for the interval 101 | // (-1,1). because of symmetry only the positive abscissae and 102 | // their corresponding weights are given. 103 | // 104 | // xgk - abscissae of the 15-point kronrod rule 105 | // xgk(2), xgk(4), ... abscissae of the 7-point 106 | // gauss rule 107 | // xgk(1), xgk(3), ... abscissae which are optimally 108 | // added to the 7-point gauss rule 109 | // 110 | // wgk - weights of the 15-point kronrod rule 111 | // 112 | // wg - weights of the 7-point gauss rule, corresponding 113 | // to the abscissae xgk(2), xgk(4), ... 114 | // wg(1), wg(3), ... are set to zero. 115 | // 116 | static immutable Real[8] wg_ = [ 117 | 0.0, 118 | 0.1294849661_6886969327_0611432679_082, 119 | 0.0, 120 | 0.2797053914_8927666790_1467771423_780, 121 | 0.0, 122 | 0.3818300505_0511894495_0369775488_975, 123 | 0.0, 124 | 0.4179591836_7346938775_5102040816_327 125 | ]; 126 | // 127 | static immutable Real[8] xgk_ = [ 128 | 0.9914553711_2081263920_6854697526_329, 129 | 0.9491079123_4275852452_6189684047_851, 130 | 0.8648644233_5976907278_9712788640_926, 131 | 0.7415311855_9939443986_3864773280_788, 132 | 0.5860872354_6769113029_4144838258_730, 133 | 0.4058451513_7739716690_6606412076_961, 134 | 0.2077849550_0789846760_0689403773_245, 135 | 0.0000000000_0000000000_0000000000_000 136 | ]; 137 | // 138 | static immutable Real[8] wgk_ = [ 139 | 0.0229353220_1052922496_3732008058_970, 140 | 0.0630920926_2997855329_0700663189_204, 141 | 0.1047900103_2225018383_9876322541_518, 142 | 0.1406532597_1552591874_5189590510_238, 143 | 0.1690047266_3926790282_6583426598_550, 144 | 0.1903505780_6478540991_3256402421_014, 145 | 0.2044329400_7529889241_4161999234_649, 146 | 0.2094821410_8472782801_2999174891_714 147 | ]; 148 | // 149 | auto fv1 = dimension(fv1_.ptr, 7); 150 | auto fv2 = dimension(fv2_.ptr, 7); 151 | auto xgk = dimension(xgk_.ptr, 8); 152 | auto wgk = dimension(wgk_.ptr, 8); 153 | auto wg = dimension(wg_.ptr, 8); 154 | // 155 | // 156 | // list of major variables 157 | // ----------------------- 158 | // 159 | // centr - mid point of the interval 160 | // hlgth - half-length of the interval 161 | // absc* - abscissa 162 | // tabsc* - transformed abscissa 163 | // fval* - function value 164 | // resg - result of the 7-point gauss formula 165 | // resk - result of the 15-point kronrod formula 166 | // reskh - approximation to the mean value of the transformed 167 | // integrand over (a,b), i.e. to i/(b-a) 168 | // 169 | // machine dependent constants 170 | // --------------------------- 171 | // 172 | // epmach is the largest relative spacing. 173 | // uflow is the smallest positive magnitude. 174 | // 175 | //***first executable statement dqk15i 176 | epmach = Real.epsilon; 177 | uflow = Real.min_normal; 178 | dinf = min(1,inf); 179 | // 180 | centr = 0.5*(a+b); 181 | hlgth = 0.5*(b-a); 182 | tabsc1 = boun+dinf*(0.1e1-centr)/centr; 183 | fval1 = f(tabsc1); 184 | if(inf == 2) fval1 = fval1+f(-tabsc1); 185 | fc = (fval1/centr)/centr; 186 | // 187 | // compute the 15-point kronrod approximation to 188 | // the integral, and estimate the error. 189 | // 190 | resg = wg[8]*fc; 191 | resk = wgk[8]*fc; 192 | resabs = fabs(resk); 193 | for (j=1; j<=7; j++) { // end: 10 194 | absc = hlgth*xgk[j]; 195 | absc1 = centr-absc; 196 | absc2 = centr+absc; 197 | tabsc1 = boun+dinf*(0.1e1-absc1)/absc1; 198 | tabsc2 = boun+dinf*(0.1e1-absc2)/absc2; 199 | fval1 = f(tabsc1); 200 | fval2 = f(tabsc2); 201 | if(inf == 2) fval1 = fval1+f(-tabsc1); 202 | if(inf == 2) fval2 = fval2+f(-tabsc2); 203 | fval1 = (fval1/absc1)/absc1; 204 | fval2 = (fval2/absc2)/absc2; 205 | fv1[j] = fval1; 206 | fv2[j] = fval2; 207 | fsum = fval1+fval2; 208 | resg = resg+wg[j]*fsum; 209 | resk = resk+wgk[j]*fsum; 210 | resabs = resabs+wgk[j]*(fabs(fval1)+fabs(fval2)); 211 | l10: ;} 212 | reskh = resk*0.5; 213 | resasc = wgk[8]*fabs(fc-reskh); 214 | for (j=1; j<=7; j++) { // end: 20 215 | resasc = resasc+wgk[j]*(fabs(fv1[j]-reskh)+fabs(fv2[j]-reskh)); 216 | l20: ;} 217 | result = resk*hlgth; 218 | resasc = resasc*hlgth; 219 | resabs = resabs*hlgth; 220 | abserr = fabs((resk-resg)*hlgth); 221 | if(resasc != 0.0 && abserr != 0.0) abserr = resasc* 222 | min(0.1e1, ((cast(Real)0.2e3)*abserr/resasc)^^(cast(Real)1.5)); 223 | if(resabs > uflow/(0.5e2*epmach)) abserr = max 224 | ((epmach*0.5e2)*resabs,abserr); 225 | return; 226 | } 227 | 228 | 229 | unittest 230 | { 231 | alias qk15i!(float, float delegate(float)) fqk15i; 232 | alias qk15i!(double, double delegate(double)) dqk15i; 233 | alias qk15i!(double, double function(double)) dfqk15i; 234 | alias qk15i!(real, real delegate(real)) rqk15i; 235 | } 236 | 237 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qk15w.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qk15w; 9 | 10 | 11 | import std.algorithm: min, max; 12 | import std.math; 13 | 14 | import scid.core.fortran; 15 | 16 | 17 | 18 | 19 | /// 20 | void qk15w(Real, Func)(Func f, Real function(Real,Real,Real,Real,Real,int) w, 21 | Real p1, Real p2, Real p3, Real p4, int kp, Real a, Real b, 22 | out Real result, out Real abserr, out Real resabs, out Real resasc) 23 | { 24 | //***begin prologue dqk15w 25 | //***date written 810101 (yymmdd) 26 | //***revision date 830518 (mmddyy) 27 | //***category no. h2a2a2 28 | //***keywords 15-point gauss-kronrod rules 29 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 30 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 31 | //***purpose to compute i = integral of f*w over (a,b), with error 32 | // estimate 33 | // j = integral of abs(f*w) over (a,b) 34 | //***description 35 | // 36 | // integration rules 37 | // standard fortran subroutine 38 | // double precision version 39 | // 40 | // parameters 41 | // on entry 42 | // f - double precision 43 | // function subprogram defining the integrand 44 | // function f(x). the actual name for f needs to be 45 | // declared e x t e r n a l in the driver program. 46 | // 47 | // w - double precision 48 | // function subprogram defining the integrand 49 | // weight function w(x). the actual name for w 50 | // needs to be declared e x t e r n a l in the 51 | // calling program. 52 | // 53 | // p1, p2, p3, p4 - double precision 54 | // parameters in the weight function 55 | // 56 | // kp - integer 57 | // key for indicating the type of weight function 58 | // 59 | // a - double precision 60 | // lower limit of integration 61 | // 62 | // b - double precision 63 | // upper limit of integration 64 | // 65 | // on return 66 | // result - double precision 67 | // approximation to the integral i 68 | // result is computed by applying the 15-point 69 | // kronrod rule (resk) obtained by optimal addition 70 | // of abscissae to the 7-point gauss rule (resg). 71 | // 72 | // abserr - double precision 73 | // estimate of the modulus of the absolute error, 74 | // which should equal or exceed abs(i-result) 75 | // 76 | // resabs - double precision 77 | // approximation to the integral of abs(f) 78 | // 79 | // resasc - double precision 80 | // approximation to the integral of abs(f-i/(b-a)) 81 | // 82 | // 83 | //***references (none) 84 | //***routines called d1mach 85 | //***end prologue dqk15w 86 | // 87 | Real absc,absc1,absc2,centr,dhlgth, 88 | epmach,fc,fsum,fval1,fval2,hlgth, 89 | resg,resk,reskh,uflow; 90 | Real[7] fv1_, fv2_; 91 | int j=1,jtw=1,jtwm1=1; 92 | // 93 | // the abscissae and weights are given for the interval (-1,1). 94 | // because of symmetry only the positive abscissae and their 95 | // corresponding weights are given. 96 | // 97 | // xgk - abscissae of the 15-point gauss-kronrod rule 98 | // xgk(2), xgk(4), ... abscissae of the 7-point 99 | // gauss rule 100 | // xgk(1), xgk(3), ... abscissae which are optimally 101 | // added to the 7-point gauss rule 102 | // 103 | // wgk - weights of the 15-point gauss-kronrod rule 104 | // 105 | // wg - weights of the 7-point gauss rule 106 | // 107 | static immutable Real[8] xgk_ = [ 108 | 0.9914553711208126, 109 | 0.9491079123427585, 110 | 0.8648644233597691, 111 | 0.7415311855993944, 112 | 0.5860872354676911, 113 | 0.4058451513773972, 114 | 0.2077849550078985, 115 | 0.0000000000000000 116 | ]; 117 | // 118 | static immutable Real[8] wgk_ = [ 119 | 0.2293532201052922e-1, 120 | 0.6309209262997855e-1, 121 | 0.1047900103222502, 122 | 0.1406532597155259, 123 | 0.1690047266392679, 124 | 0.1903505780647854, 125 | 0.2044329400752989, 126 | 0.2094821410847278 127 | ]; 128 | // 129 | static immutable Real[4] wg_ = [ 130 | 0.1294849661688697, 131 | 0.2797053914892767, 132 | 0.3818300505051889, 133 | 0.4179591836734694 134 | ]; 135 | // 136 | auto fv1 = dimension(fv1_.ptr, 7); 137 | auto fv2 = dimension(fv2_.ptr, 7); 138 | auto xgk = dimension(xgk_.ptr, 8); 139 | auto wgk = dimension(wgk_.ptr, 8); 140 | auto wg = dimension(wg_.ptr, 4); 141 | // 142 | // 143 | // list of major variables 144 | // ----------------------- 145 | // 146 | // centr - mid point of the interval 147 | // hlgth - half-length of the interval 148 | // absc* - abscissa 149 | // fval* - function value 150 | // resg - result of the 7-point gauss formula 151 | // resk - result of the 15-point kronrod formula 152 | // reskh - approximation to the mean value of f*w over (a,b), 153 | // i.e. to i/(b-a) 154 | // 155 | // machine dependent constants 156 | // --------------------------- 157 | // 158 | // epmach is the largest relative spacing. 159 | // uflow is the smallest positive magnitude. 160 | // 161 | //***first executable statement dqk15w 162 | epmach = Real.epsilon; 163 | uflow = Real.min_normal; 164 | // 165 | centr = 0.5*(a+b); 166 | hlgth = 0.5*(b-a); 167 | dhlgth = fabs(hlgth); 168 | // 169 | // compute the 15-point kronrod approximation to the 170 | // integral, and estimate the error. 171 | // 172 | fc = f(centr)*w(centr,p1,p2,p3,p4,kp); 173 | resg = wg[4]*fc; 174 | resk = wgk[8]*fc; 175 | resabs = fabs(resk); 176 | for (j=1; j<=3; j++) { // end: 10 177 | jtw = j*2; 178 | absc = hlgth*xgk[jtw]; 179 | absc1 = centr-absc; 180 | absc2 = centr+absc; 181 | fval1 = f(absc1)*w(absc1,p1,p2,p3,p4,kp); 182 | fval2 = f(absc2)*w(absc2,p1,p2,p3,p4,kp); 183 | fv1[jtw] = fval1; 184 | fv2[jtw] = fval2; 185 | fsum = fval1+fval2; 186 | resg = resg+wg[j]*fsum; 187 | resk = resk+wgk[jtw]*fsum; 188 | resabs = resabs+wgk[jtw]*(fabs(fval1)+fabs(fval2)); 189 | l10:;} 190 | for(j=1; j<=4; j++) { // end: 15 191 | jtwm1 = j*2-1; 192 | absc = hlgth*xgk[jtwm1]; 193 | absc1 = centr-absc; 194 | absc2 = centr+absc; 195 | fval1 = f(absc1)*w(absc1,p1,p2,p3,p4,kp); 196 | fval2 = f(absc2)*w(absc2,p1,p2,p3,p4,kp); 197 | fv1[jtwm1] = fval1; 198 | fv2[jtwm1] = fval2; 199 | fsum = fval1+fval2; 200 | resk = resk+wgk[jtwm1]*fsum; 201 | resabs = resabs+wgk[jtwm1]*(fabs(fval1)+fabs(fval2)); 202 | l15:;} 203 | reskh = resk*0.5; 204 | resasc = wgk[8]*fabs(fc-reskh); 205 | for (j=1; j<=7; j++) { // end: 20 206 | resasc = resasc+wgk[j]*(fabs(fv1[j]-reskh)+fabs(fv2[j]-reskh)); 207 | l20:;} 208 | result = resk*hlgth; 209 | resabs = resabs*dhlgth; 210 | resasc = resasc*dhlgth; 211 | abserr = fabs((resk-resg)*hlgth); 212 | if(resasc != 0.0 && abserr != 0.0) 213 | abserr = resasc*min(0.1e1, ((cast(Real)0.2e3)*abserr/resasc)^^(cast(Real)1.5)); 214 | if(resabs > uflow/(0.5e2*epmach)) abserr = max((epmach* 215 | 0.5e2)*resabs,abserr); 216 | return; 217 | } 218 | 219 | 220 | unittest 221 | { 222 | alias qk15w!(float, float delegate(float)) fqk15w; 223 | alias qk15w!(double, double delegate(double)) dqk15w; 224 | alias qk15w!(double, double function(double)) dfqk15w; 225 | alias qk15w!(real, real delegate(real)) rqk15w; 226 | } 227 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qk21.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | // An idiomatic D port can be found in scid.internal.calculus.integrate_qk. 4 | 5 | /** Authors: Lars Tandle Kyllingstad 6 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 7 | License: Boost License 1.0 8 | */ 9 | module scid.ports.quadpack.qk21; 10 | 11 | 12 | import std.algorithm: max, min; 13 | import std.math; 14 | 15 | import scid.core.fortran; 16 | 17 | 18 | 19 | 20 | /// 21 | void qk21(Real, Func)(Func f, Real a, Real b, out Real result, 22 | out Real abserr, out Real resabs, out Real resasc) 23 | { 24 | //***begin prologue dqk21 25 | //***date written 800101 (yymmdd) 26 | //***revision date 830518 (yymmdd) 27 | //***category no. h2a1a2 28 | //***keywords 21-point gauss-kronrod rules 29 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 30 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 31 | //***purpose to compute i = integral of f over (a,b), with error 32 | // estimate 33 | // j = integral of abs(f) over (a,b) 34 | //***description 35 | // 36 | // integration rules 37 | // standard fortran subroutine 38 | // double precision version 39 | // 40 | // parameters 41 | // on entry 42 | // f - double precision 43 | // function subprogram defining the integrand 44 | // function f(x). the actual name for f needs to be 45 | // declared e x t e r n a l in the driver program. 46 | // 47 | // a - double precision 48 | // lower limit of integration 49 | // 50 | // b - double precision 51 | // upper limit of integration 52 | // 53 | // on return 54 | // result - double precision 55 | // approximation to the integral i 56 | // result is computed by applying the 21-point 57 | // kronrod rule (resk) obtained by optimal addition 58 | // of abscissae to the 10-point gauss rule (resg). 59 | // 60 | // abserr - double precision 61 | // estimate of the modulus of the absolute error, 62 | // which should not exceed abs(i-result) 63 | // 64 | // resabs - double precision 65 | // approximation to the integral j 66 | // 67 | // resasc - double precision 68 | // approximation to the integral of abs(f-i/(b-a)) 69 | // over (a,b) 70 | // 71 | //***references (none) 72 | //***routines called d1mach 73 | //***end prologue dqk21 74 | // 75 | Real absc,centr,dhlgth, 76 | epmach,fc,fsum,fval1,fval2,hlgth, 77 | resg,resk,reskh,uflow; 78 | Real[10] fv1_, fv2_; 79 | int j,jtw,jtwm1; 80 | // 81 | // the abscissae and weights are given for the interval (-1,1). 82 | // because of symmetry only the positive abscissae and their 83 | // corresponding weights are given. 84 | // 85 | // xgk - abscissae of the 21-point kronrod rule 86 | // xgk(2), xgk(4), ... abscissae of the 10-point 87 | // gauss rule 88 | // xgk(1), xgk(3), ... abscissae which are optimally 89 | // added to the 10-point gauss rule 90 | // 91 | // wgk - weights of the 21-point kronrod rule 92 | // 93 | // wg - weights of the 10-point gauss rule 94 | // 95 | // 96 | // gauss quadrature weights and kronron quadrature abscissae and weights 97 | // as evaluated with 80 decimal digit arithmetic by l. w. fullerton, 98 | // bell labs, nov. 1981. 99 | // 100 | static immutable Real[5] wg_ = [ 101 | 0.0666713443_0868813759_3568809893_332, 102 | 0.1494513491_5058059314_5776339657_697, 103 | 0.2190863625_1598204399_5534934228_163, 104 | 0.2692667193_0999635509_1226921569_469, 105 | 0.2955242247_1475287017_3892994651_338]; 106 | // 107 | static immutable Real[11] xgk_ = [ 108 | 0.9956571630_2580808073_5527280689_003, 109 | 0.9739065285_1717172007_7964012084_452, 110 | 0.9301574913_5570822600_1207180059_508, 111 | 0.8650633666_8898451073_2096688423_493, 112 | 0.7808177265_8641689706_3717578345_042, 113 | 0.6794095682_9902440623_4327365114_874, 114 | 0.5627571346_6860468333_9000099272_694, 115 | 0.4333953941_2924719079_9265943165_784, 116 | 0.2943928627_0146019813_1126603103_866, 117 | 0.1488743389_8163121088_4826001129_720, 118 | 0.0000000000_0000000000_0000000000_000]; 119 | // 120 | static immutable Real[11] wgk_ = [ 121 | 0.0116946388_6737187427_8064396062_192, 122 | 0.0325581623_0796472747_8818972459_390, 123 | 0.0547558965_7435199603_1381300244_580, 124 | 0.0750396748_1091995276_7043140916_190, 125 | 0.0931254545_8369760553_5065465083_366, 126 | 0.1093871588_0229764189_9210590325_805, 127 | 0.1234919762_6206585107_7958109831_074, 128 | 0.1347092173_1147332592_8054001771_707, 129 | 0.1427759385_7706008079_7094273138_717, 130 | 0.1477391049_0133849137_4841515972_068, 131 | 0.1494455540_0291690566_4936468389_821]; 132 | // 133 | auto fv1 = dimension(fv1_.ptr, 10); 134 | auto fv2 = dimension(fv2_.ptr, 10); 135 | auto wg = dimension(wg_.ptr, 5); 136 | auto wgk = dimension(wgk_.ptr, 11); 137 | auto xgk = dimension(xgk_.ptr, 11); 138 | // 139 | // 140 | // list of major variables 141 | // ----------------------- 142 | // 143 | // centr - mid point of the interval 144 | // hlgth - half-length of the interval 145 | // absc - abscissa 146 | // fval* - function value 147 | // resg - result of the 10-point gauss formula 148 | // resk - result of the 21-point kronrod formula 149 | // reskh - approximation to the mean value of f over (a,b), 150 | // i.e. to i/(b-a) 151 | // 152 | // 153 | // machine dependent constants 154 | // --------------------------- 155 | // 156 | // epmach is the largest relative spacing. 157 | // uflow is the smallest positive magnitude. 158 | // 159 | //***first executable statement dqk21 160 | epmach = Real.epsilon; 161 | uflow = Real.min_normal; 162 | // 163 | centr = 0.5*(a+b); 164 | hlgth = 0.5*(b-a); 165 | dhlgth = fabs(hlgth); 166 | // 167 | // compute the 21-point kronrod approximation to 168 | // the integral, and estimate the absolute error. 169 | // 170 | resg = 0.0; 171 | fc = f(centr); 172 | resk = wgk[11]*fc; 173 | resabs = fabs(resk); 174 | for (j=1; j<=5; j++) { //do 10 j = 1,5 175 | jtw = 2*j; 176 | absc = hlgth*xgk[jtw]; 177 | fval1 = f(centr-absc); 178 | fval2 = f(centr+absc); 179 | fv1[jtw] = fval1; 180 | fv2[jtw] = fval2; 181 | fsum = fval1+fval2; 182 | resg = resg+wg[j]*fsum; 183 | resk = resk+wgk[jtw]*fsum; 184 | resabs = resabs+wgk[jtw]*(fabs(fval1)+fabs(fval2)); 185 | l10: ;} 186 | for (j=1; j<=5; j++) { //do 15 j = 1,5 187 | jtwm1 = 2*j-1; 188 | absc = hlgth*xgk[jtwm1]; 189 | fval1 = f(centr-absc); 190 | fval2 = f(centr+absc); 191 | fv1[jtwm1] = fval1; 192 | fv2[jtwm1] = fval2; 193 | fsum = fval1+fval2; 194 | resk = resk+wgk[jtwm1]*fsum; 195 | resabs = resabs+wgk[jtwm1]*(fabs(fval1)+fabs(fval2)); 196 | l15: ;} 197 | reskh = resk*0.5; 198 | resasc = wgk[11]*fabs(fc-reskh); 199 | for (j=1; j<=10; j++) { //do 20 j=1,10 200 | resasc = resasc+wgk[j]*(fabs(fv1[j]-reskh)+fabs(fv2[j]-reskh)); 201 | l20: ;} 202 | result = resk*hlgth; 203 | resabs = resabs*dhlgth; 204 | resasc = resasc*dhlgth; 205 | abserr = fabs((resk-resg)*hlgth); 206 | if(resasc != 0.0 && abserr != 0.0) 207 | abserr = resasc*min(0.1e1,((cast(Real)0.2e3)*abserr/resasc)^^(cast(Real)1.5)); 208 | if(resabs > uflow/(0.5e2*epmach)) abserr = max 209 | ((epmach*0.5e2)*resabs,abserr); 210 | return; 211 | } 212 | 213 | version(unittest) import scid.core.testing; 214 | unittest 215 | { 216 | alias qk21!(float, float delegate(float)) fqk21; 217 | alias qk21!(double, double delegate(double)) dqk21; 218 | alias qk21!(double, double function(double)) dfqk21; 219 | alias qk21!(real, real delegate(real)) rqk21; 220 | 221 | double f(double x) { return x^^3; } 222 | double result, abserr, resabs, resasc; 223 | qk21(&f, 0.0, 1.0, result, abserr, resabs, resasc); 224 | assert (isAccurate(result, abserr, 0.25, 1e-6)); 225 | } 226 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qk31.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | // An idiomatic D port can be found in scid.internal.calculus.integrate_qk. 4 | 5 | /** Authors: Lars Tandle Kyllingstad 6 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 7 | License: Boost License 1.0 8 | */ 9 | module scid.ports.quadpack.qk31; 10 | 11 | 12 | import std.algorithm: max, min; 13 | import std.math; 14 | 15 | import scid.core.fortran; 16 | 17 | 18 | 19 | 20 | /// 21 | void qk31(Real, Func)(Func f, Real a, Real b, out Real result, 22 | out Real abserr, out Real resabs, out Real resasc) 23 | { 24 | //***begin prologue dqk31 25 | //***date written 800101 (yymmdd) 26 | //***revision date 830518 (yymmdd) 27 | //***category no. h2a1a2 28 | //***keywords 31-point gauss-kronrod rules 29 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 30 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 31 | //***purpose to compute i = integral of f over (a,b) with error 32 | // estimate 33 | // j = integral of abs(f) over (a,b) 34 | //***description 35 | // 36 | // integration rules 37 | // standard fortran subroutine 38 | // double precision version 39 | // 40 | // parameters 41 | // on entry 42 | // f - double precision 43 | // function subprogram defining the integrand 44 | // function f(x). the actual name for f needs to be 45 | // declared e x t e r n a l in the calling program. 46 | // 47 | // a - double precision 48 | // lower limit of integration 49 | // 50 | // b - double precision 51 | // upper limit of integration 52 | // 53 | // on return 54 | // result - double precision 55 | // approximation to the integral i 56 | // result is computed by applying the 31-point 57 | // gauss-kronrod rule (resk), obtained by optimal 58 | // addition of abscissae to the 15-point gauss 59 | // rule (resg). 60 | // 61 | // abserr - double precison 62 | // estimate of the modulus of the modulus, 63 | // which should not exceed abs(i-result) 64 | // 65 | // resabs - double precision 66 | // approximation to the integral j 67 | // 68 | // resasc - double precision 69 | // approximation to the integral of abs(f-i/(b-a)) 70 | // over (a,b) 71 | // 72 | //***references (none) 73 | //***routines called d1mach 74 | //***end prologue dqk31 75 | Real absc,centr,dhlgth, 76 | epmach,fc,fsum,fval1,fval2,hlgth, 77 | resg,resk,reskh,uflow; 78 | Real[15] fv1_, fv2_; 79 | int j=1,jtw=1,jtwm1=1; 80 | // 81 | // the abscissae and weights are given for the interval (-1,1). 82 | // because of symmetry only the positive abscissae and their 83 | // corresponding weights are given. 84 | // 85 | // xgk - abscissae of the 31-point kronrod rule 86 | // xgk(2), xgk(4), ... abscissae of the 15-point 87 | // gauss rule 88 | // xgk(1), xgk(3), ... abscissae which are optimally 89 | // added to the 15-point gauss rule 90 | // 91 | // wgk - weights of the 31-point kronrod rule 92 | // 93 | // wg - weights of the 15-point gauss rule 94 | // 95 | // 96 | // gauss quadrature weights and kronron quadrature abscissae and weights 97 | // as evaluated with 80 decimal digit arithmetic by l. w. fullerton, 98 | // bell labs, nov. 1981. 99 | // 100 | immutable static Real[8] wg_ = [ 101 | 0.0307532419_9611726835_4628393577_204, 102 | 0.0703660474_8810812470_9267416450_667, 103 | 0.1071592204_6717193501_1869546685_869, 104 | 0.1395706779_2615431444_7804794511_028, 105 | 0.1662692058_1699393355_3200860481_209, 106 | 0.1861610000_1556221102_6800561866_423, 107 | 0.1984314853_2711157645_6118326443_839, 108 | 0.2025782419_2556127288_0620199967_519]; 109 | // 110 | immutable static Real[16] xgk_ = [ 111 | 0.9980022986_9339706028_5172840152_271, 112 | 0.9879925180_2048542848_9565718586_613, 113 | 0.9677390756_7913913425_7347978784_337, 114 | 0.9372733924_0070590430_7758947710_209, 115 | 0.8972645323_4408190088_2509656454_496, 116 | 0.8482065834_1042721620_0648320774_217, 117 | 0.7904185014_4246593296_7649294817_947, 118 | 0.7244177313_6017004741_6186054613_938, 119 | 0.6509967412_9741697053_3735895313_275, 120 | 0.5709721726_0853884753_7226737253_911, 121 | 0.4850818636_4023968069_3655740232_351, 122 | 0.3941513470_7756336989_7207370981_045, 123 | 0.2991800071_5316881216_6780024266_389, 124 | 0.2011940939_9743452230_0628303394_596, 125 | 0.1011420669_1871749902_7074231447_392, 126 | 0.0000000000_0000000000_0000000000_000]; 127 | // 128 | immutable static Real[16] wgk_ = [ 129 | 0.0053774798_7292334898_7792051430_128, 130 | 0.0150079473_2931612253_8374763075_807, 131 | 0.0254608473_2671532018_6874001019_653, 132 | 0.0353463607_9137584622_2037948478_360, 133 | 0.0445897513_2476487660_8227299373_280, 134 | 0.0534815246_9092808726_5343147239_430, 135 | 0.0620095678_0067064028_5139230960_803, 136 | 0.0698541213_1872825870_9520077099_147, 137 | 0.0768496807_5772037889_4432777482_659, 138 | 0.0830805028_2313302103_8289247286_104, 139 | 0.0885644430_5621177064_7275443693_774, 140 | 0.0931265981_7082532122_5486872747_346, 141 | 0.0966427269_8362367850_5179907627_589, 142 | 0.0991735987_2179195933_2393173484_603, 143 | 0.1007698455_2387559504_4946662617_570, 144 | 0.1013300070_1479154901_7374792767_493]; 145 | // 146 | auto fv1 = dimension(fv1_.ptr, 15); 147 | auto fv2 = dimension(fv2_.ptr, 15); 148 | auto wg = dimension(wg_.ptr, 8); 149 | auto wgk = dimension(wgk_.ptr, 16); 150 | auto xgk = dimension(xgk_.ptr, 16); 151 | // 152 | // 153 | // list of major variables 154 | // ----------------------- 155 | // centr - mid point of the interval 156 | // hlgth - half-length of the interval 157 | // absc - abscissa 158 | // fval* - function value 159 | // resg - result of the 15-point gauss formula 160 | // resk - result of the 31-point kronrod formula 161 | // reskh - approximation to the mean value of f over (a,b), 162 | // i.e. to i/(b-a) 163 | // 164 | // machine dependent constants 165 | // --------------------------- 166 | // epmach is the largest relative spacing. 167 | // uflow is the smallest positive magnitude. 168 | //***first executable statement dqk31 169 | epmach = Real.epsilon; 170 | uflow = Real.min_normal; 171 | // 172 | centr = 0.5*(a+b); 173 | hlgth = 0.5*(b-a); 174 | dhlgth = fabs(hlgth); 175 | // 176 | // compute the 31-point kronrod approximation to 177 | // the integral, and estimate the absolute error. 178 | // 179 | fc = f(centr); 180 | resg = wg[8]*fc; 181 | resk = wgk[16]*fc; 182 | resabs = fabs(resk); 183 | for (j=1; j<=7; j++) { //do 10 j=1,7 184 | jtw = j*2; 185 | absc = hlgth*xgk[jtw]; 186 | fval1 = f(centr-absc); 187 | fval2 = f(centr+absc); 188 | fv1[jtw] = fval1; 189 | fv2[jtw] = fval2; 190 | fsum = fval1+fval2; 191 | resg = resg+wg[j]*fsum; 192 | resk = resk+wgk[jtw]*fsum; 193 | resabs = resabs+wgk[jtw]*(fabs(fval1)+fabs(fval2)); 194 | l10: ;} 195 | for (j=1; j<=8; j++) { //do 15 j = 1,8 196 | jtwm1 = j*2-1; 197 | absc = hlgth*xgk[jtwm1]; 198 | fval1 = f(centr-absc); 199 | fval2 = f(centr+absc); 200 | fv1[jtwm1] = fval1; 201 | fv2[jtwm1] = fval2; 202 | fsum = fval1+fval2; 203 | resk = resk+wgk[jtwm1]*fsum; 204 | resabs = resabs+wgk[jtwm1]*(fabs(fval1)+fabs(fval2)); 205 | l15: ;} 206 | reskh = resk*0.5; 207 | resasc = wgk[16]*fabs(fc-reskh); 208 | for (j=1; j<=15; j++) { //do 20 j=1,15 209 | resasc = resasc+wgk[j]*(fabs(fv1[j]-reskh)+fabs(fv2[j]-reskh)); 210 | l20: ;} 211 | result = resk*hlgth; 212 | resabs = resabs*dhlgth; 213 | resasc = resasc*dhlgth; 214 | abserr = fabs((resk-resg)*hlgth); 215 | if(resasc != 0.0 && abserr != 0.0) 216 | abserr = resasc*min(0.1e1,((cast(Real)0.2e3)*abserr/resasc)^^(cast(Real)1.5)); 217 | if(resabs > uflow/(0.5e2*epmach)) abserr = max 218 | ((epmach*0.5e2)*resabs,abserr); 219 | return; 220 | } 221 | 222 | version(unittest) import scid.core.testing; 223 | unittest 224 | { 225 | alias qk31!(float, float delegate(float)) fqk31; 226 | alias qk31!(double, double delegate(double)) dqk31; 227 | alias qk31!(double, double function(double)) dfqk31; 228 | alias qk31!(real, real delegate(real)) rqk31; 229 | 230 | double f(double x) { return x^^3; } 231 | double result, abserr, resabs, resasc; 232 | qk31(&f, 0.0, 1.0, result, abserr, resabs, resasc); 233 | assert (isAccurate(result, abserr, 0.25, 1e-6)); 234 | } 235 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qk41.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | // An idiomatic D port can be found in scid.internal.calculus.integrate_qk. 4 | 5 | /** Authors: Lars Tandle Kyllingstad 6 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 7 | License: Boost License 1.0 8 | */ 9 | module scid.ports.quadpack.qk41; 10 | 11 | 12 | import std.algorithm: max, min; 13 | import std.math; 14 | 15 | import scid.core.fortran; 16 | 17 | 18 | 19 | 20 | /// 21 | void qk41(Real, Func)(Func f, Real a, Real b, out Real result, out Real abserr, 22 | out Real resabs, out Real resasc) 23 | { 24 | //***begin prologue dqk41 25 | //***date written 800101 (yymmdd) 26 | //***revision date 830518 (yymmdd) 27 | //***category no. h2a1a2 28 | //***keywords 41-point gauss-kronrod rules 29 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 30 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 31 | //***purpose to compute i = integral of f over (a,b), with error 32 | // estimate 33 | // j = integral of abs(f) over (a,b) 34 | //***description 35 | // 36 | // integration rules 37 | // standard fortran subroutine 38 | // double precision version 39 | // 40 | // parameters 41 | // on entry 42 | // f - double precision 43 | // function subprogram defining the integrand 44 | // function f(x). the actual name for f needs to be 45 | // declared e x t e r n a l in the calling program. 46 | // 47 | // a - double precision 48 | // lower limit of integration 49 | // 50 | // b - double precision 51 | // upper limit of integration 52 | // 53 | // on return 54 | // result - double precision 55 | // approximation to the integral i 56 | // result is computed by applying the 41-point 57 | // gauss-kronrod rule (resk) obtained by optimal 58 | // addition of abscissae to the 20-point gauss 59 | // rule (resg). 60 | // 61 | // abserr - double precision 62 | // estimate of the modulus of the absolute error, 63 | // which should not exceed abs(i-result) 64 | // 65 | // resabs - double precision 66 | // approximation to the integral j 67 | // 68 | // resasc - double precision 69 | // approximation to the integal of abs(f-i/(b-a)) 70 | // over (a,b) 71 | // 72 | //***references (none) 73 | //***routines called d1mach 74 | //***end prologue dqk41 75 | // 76 | Real absc,centr,dhlgth, 77 | epmach,fc,fsum,fval1,fval2,hlgth, 78 | resg,resk,reskh,uflow; 79 | Real[20] fv1_, fv2_; 80 | int j,jtw,jtwm1; 81 | // 82 | // the abscissae and weights are given for the interval (-1,1). 83 | // because of symmetry only the positive abscissae and their 84 | // corresponding weights are given. 85 | // 86 | // xgk - abscissae of the 41-point gauss-kronrod rule 87 | // xgk(2), xgk(4), ... abscissae of the 20-point 88 | // gauss rule 89 | // xgk(1), xgk(3), ... abscissae which are optimally 90 | // added to the 20-point gauss rule 91 | // 92 | // wgk - weights of the 41-point gauss-kronrod rule 93 | // 94 | // wg - weights of the 20-point gauss rule 95 | // 96 | // 97 | // gauss quadrature weights and kronron quadrature abscissae and weights 98 | // as evaluated with 80 decimal digit arithmetic by l. w. fullerton, 99 | // bell labs, nov. 1981. 100 | // 101 | static immutable Real[10] wg_ = [ 102 | 0.0176140071_3915211831_1861962351_853, 103 | 0.0406014298_0038694133_1039952274_932, 104 | 0.0626720483_3410906356_9506535187_042, 105 | 0.0832767415_7670474872_4758143222_046, 106 | 0.1019301198_1724043503_6750135480_350, 107 | 0.1181945319_6151841731_2377377711_382, 108 | 0.1316886384_4917662689_8494499748_163, 109 | 0.1420961093_1838205132_9298325067_165, 110 | 0.1491729864_7260374678_7828737001_969, 111 | 0.1527533871_3072585069_8084331955_098]; 112 | // 113 | static immutable Real[21] xgk_ = [ 114 | 0.9988590315_8827766383_8315576545_863, 115 | 0.9931285991_8509492478_6122388471_320, 116 | 0.9815078774_5025025919_3342994720_217, 117 | 0.9639719272_7791379126_7666131197_277, 118 | 0.9408226338_3175475351_9982722212_443, 119 | 0.9122344282_5132590586_7752441203_298, 120 | 0.8782768112_5228197607_7442995113_078, 121 | 0.8391169718_2221882339_4529061701_521, 122 | 0.7950414288_3755119835_0638833272_788, 123 | 0.7463319064_6015079261_4305070355_642, 124 | 0.6932376563_3475138480_5490711845_932, 125 | 0.6360536807_2651502545_2836696226_286, 126 | 0.5751404468_1971031534_2946036586_425, 127 | 0.5108670019_5082709800_4364050955_251, 128 | 0.4435931752_3872510319_9992213492_640, 129 | 0.3737060887_1541956067_2548177024_927, 130 | 0.3016278681_1491300432_0555356858_592, 131 | 0.2277858511_4164507808_0496195368_575, 132 | 0.1526054652_4092267550_5220241022_678, 133 | 0.0765265211_3349733375_4640409398_838, 134 | 0.0000000000_0000000000_0000000000_000]; 135 | // 136 | static immutable Real[21] wgk_ = [ 137 | 0.0030735837_1852053150_1218293246_031, 138 | 0.0086002698_5564294219_8661787950_102, 139 | 0.0146261692_5697125298_3787960308_868, 140 | 0.0203883734_6126652359_8010231432_755, 141 | 0.0258821336_0495115883_4505067096_153, 142 | 0.0312873067_7703279895_8543119323_801, 143 | 0.0366001697_5820079803_0557240707_211, 144 | 0.0416688733_2797368626_3788305936_895, 145 | 0.0464348218_6749767472_0231880926_108, 146 | 0.0509445739_2372869193_2707670050_345, 147 | 0.0551951053_4828599474_4832372419_777, 148 | 0.0591114008_8063957237_4967220648_594, 149 | 0.0626532375_5478116802_5870122174_255, 150 | 0.0658345971_3361842211_1563556969_398, 151 | 0.0686486729_2852161934_5623411885_368, 152 | 0.0710544235_5344406830_5790361723_210, 153 | 0.0730306903_3278666749_5189417658_913, 154 | 0.0745828754_0049918898_6581418362_488, 155 | 0.0757044976_8455667465_9542775376_617, 156 | 0.0763778676_7208073670_5502835038_061, 157 | 0.0766007119_1799965644_5049901530_102]; 158 | // 159 | auto fv1 = dimension(fv1_.ptr, 20); 160 | auto fv2 = dimension(fv2_.ptr, 20); 161 | auto xgk = dimension(xgk_.ptr, 21); 162 | auto wgk = dimension(wgk_.ptr, 21); 163 | auto wg = dimension(wg_.ptr, 10); 164 | // 165 | // 166 | // list of major variables 167 | // ----------------------- 168 | // 169 | // centr - mid point of the interval 170 | // hlgth - half-length of the interval 171 | // absc - abscissa 172 | // fval* - function value 173 | // resg - result of the 20-point gauss formula 174 | // resk - result of the 41-point kronrod formula 175 | // reskh - approximation to mean value of f over (a,b), i.e. 176 | // to i/(b-a) 177 | // 178 | // machine dependent constants 179 | // --------------------------- 180 | // 181 | // epmach is the largest relative spacing. 182 | // uflow is the smallest positive magnitude. 183 | // 184 | //***first executable statement dqk41 185 | epmach = Real.epsilon; 186 | uflow = Real.min_normal; 187 | // 188 | centr = 0.5*(a+b); 189 | hlgth = 0.5*(b-a); 190 | dhlgth = fabs(hlgth); 191 | // 192 | // compute the 41-point gauss-kronrod approximation to 193 | // the integral, and estimate the absolute error. 194 | // 195 | resg = 0.0; 196 | fc = f(centr); 197 | resk = wgk[21]*fc; 198 | resabs = fabs(resk); 199 | for (j=1; j<=10; j++) { //do 10 j=1,10 200 | jtw = j*2; 201 | absc = hlgth*xgk[jtw]; 202 | fval1 = f(centr-absc); 203 | fval2 = f(centr+absc); 204 | fv1[jtw] = fval1; 205 | fv2[jtw] = fval2; 206 | fsum = fval1+fval2; 207 | resg = resg+wg[j]*fsum; 208 | resk = resk+wgk[jtw]*fsum; 209 | resabs = resabs+wgk[jtw]*(fabs(fval1)+fabs(fval2)); 210 | l10: ;} 211 | for (j=1; j<=10; j++) { //do 15 j = 1,10 212 | jtwm1 = j*2-1; 213 | absc = hlgth*xgk[jtwm1]; 214 | fval1 = f(centr-absc); 215 | fval2 = f(centr+absc); 216 | fv1[jtwm1] = fval1; 217 | fv2[jtwm1] = fval2; 218 | fsum = fval1+fval2; 219 | resk = resk+wgk[jtwm1]*fsum; 220 | resabs = resabs+wgk[jtwm1]*(fabs(fval1)+fabs(fval2)); 221 | l15: ;} 222 | reskh = resk*0.5; 223 | resasc = wgk[21]*fabs(fc-reskh); 224 | for (j=1; j<=20; j++) { //do 20 j=1,20 225 | resasc = resasc+wgk[j]*(fabs(fv1[j]-reskh)+fabs(fv2[j]-reskh)); 226 | l20: ;} 227 | result = resk*hlgth; 228 | resabs = resabs*dhlgth; 229 | resasc = resasc*dhlgth; 230 | abserr = fabs((resk-resg)*hlgth); 231 | if(resasc != 0.0 && abserr != 0.) 232 | abserr = resasc*min(0.1e1,((cast(Real)0.2e3)*abserr/resasc)^^(cast(Real)1.5)); 233 | if(resabs > uflow/(0.5e2*epmach)) abserr = max 234 | ((epmach*0.5e2)*resabs,abserr); 235 | return; 236 | } 237 | 238 | version(unittest) import scid.core.testing; 239 | unittest 240 | { 241 | alias qk41!(float, float delegate(float)) fqk41; 242 | alias qk41!(double, double delegate(double)) dqk41; 243 | alias qk41!(double, double function(double)) dfqk41; 244 | alias qk41!(real, real delegate(real)) rqk41; 245 | 246 | double f(double x) { return x^^3; } 247 | double result, abserr, resabs, resasc; 248 | qk41(&f, 0.0, 1.0, result, abserr, resabs, resasc); 249 | assert (isAccurate(result, abserr, 0.25, 1e-6)); 250 | } 251 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qk51.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | // An idiomatic D port can be found in scid.internal.calculus.integrate_qk. 4 | 5 | /** Authors: Lars Tandle Kyllingstad 6 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 7 | License: Boost License 1.0 8 | */ 9 | module scid.ports.quadpack.qk51; 10 | 11 | 12 | import std.algorithm: max, min; 13 | import std.math; 14 | 15 | import scid.core.fortran; 16 | 17 | 18 | 19 | 20 | /// 21 | void qk51(Real, Func)(Func f, Real a, Real b, out Real result, out Real abserr, 22 | out Real resabs, out Real resasc) 23 | { 24 | //***begin prologue dqk51 25 | //***date written 800101 (yymmdd) 26 | //***revision date 830518 (yymmdd) 27 | //***category no. h2a1a2 28 | //***keywords 51-point gauss-kronrod rules 29 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 30 | // de doncker,elise,appl. math & progr. div. - k.u.leuven 31 | //***purpose to compute i = integral of f over (a,b) with error 32 | // estimate 33 | // j = integral of abs(f) over (a,b) 34 | //***description 35 | // 36 | // integration rules 37 | // standard fortran subroutine 38 | // double precision version 39 | // 40 | // parameters 41 | // on entry 42 | // f - double precision 43 | // function subroutine defining the integrand 44 | // function f(x). the actual name for f needs to be 45 | // declared e x t e r n a l in the calling program. 46 | // 47 | // a - double precision 48 | // lower limit of integration 49 | // 50 | // b - double precision 51 | // upper limit of integration 52 | // 53 | // on return 54 | // result - double precision 55 | // approximation to the integral i 56 | // result is computed by applying the 51-point 57 | // kronrod rule (resk) obtained by optimal addition 58 | // of abscissae to the 25-point gauss rule (resg). 59 | // 60 | // abserr - double precision 61 | // estimate of the modulus of the absolute error, 62 | // which should not exceed abs(i-result) 63 | // 64 | // resabs - double precision 65 | // approximation to the integral j 66 | // 67 | // resasc - double precision 68 | // approximation to the integral of abs(f-i/(b-a)) 69 | // over (a,b) 70 | // 71 | //***references (none) 72 | //***routines called d1mach 73 | //***end prologue dqk51 74 | // 75 | Real absc,centr,dhlgth, 76 | epmach,fc,fsum,fval1,fval2,hlgth, 77 | resg,resk,reskh,uflow; 78 | Real[25] fv1_, fv2_; 79 | int j,jtw,jtwm1; 80 | // 81 | // the abscissae and weights are given for the interval (-1,1). 82 | // because of symmetry only the positive abscissae and their 83 | // corresponding weights are given. 84 | // 85 | // xgk - abscissae of the 51-point kronrod rule 86 | // xgk(2), xgk(4), ... abscissae of the 25-point 87 | // gauss rule 88 | // xgk(1), xgk(3), ... abscissae which are optimally 89 | // added to the 25-point gauss rule 90 | // 91 | // wgk - weights of the 51-point kronrod rule 92 | // 93 | // wg - weights of the 25-point gauss rule 94 | // 95 | // 96 | // gauss quadrature weights and kronron quadrature abscissae and weights 97 | // as evaluated with 80 decimal digit arithmetic by l. w. fullerton, 98 | // bell labs, nov. 1981. 99 | // 100 | static immutable Real[13] wg_ = [ 101 | 0.0113937985_0102628794_7902964113_235, 102 | 0.0263549866_1503213726_1901815295_299, 103 | 0.0409391567_0130631265_5623487711_646, 104 | 0.0549046959_7583519192_5936891540_473, 105 | 0.0680383338_1235691720_7187185656_708, 106 | 0.0801407003_3500101801_3234959669_111, 107 | 0.0910282619_8296364981_1497220702_892, 108 | 0.1005359490_6705064420_2206890392_686, 109 | 0.1085196244_7426365311_6093957050_117, 110 | 0.1148582591_4571164833_9325545869_556, 111 | 0.1194557635_3578477222_8178126512_901, 112 | 0.1222424429_9031004168_8959518945_852, 113 | 0.1231760537_2671545120_3902873079_050]; 114 | // 115 | static immutable Real[26] xgk_ = [ 116 | 0.9992621049_9260983419_3457486540_341, 117 | 0.9955569697_9049809790_8784946893_902, 118 | 0.9880357945_3407724763_7331014577_406, 119 | 0.9766639214_5951751149_8315386479_594, 120 | 0.9616149864_2584251241_8130033660_167, 121 | 0.9429745712_2897433941_4011169658_471, 122 | 0.9207471152_8170156174_6346084546_331, 123 | 0.8949919978_7827536885_1042006782_805, 124 | 0.8658470652_9327559544_8996969588_340, 125 | 0.8334426287_6083400142_1021108693_570, 126 | 0.7978737979_9850005941_0410904994_307, 127 | 0.7592592630_3735763057_7282865204_361, 128 | 0.7177664068_1308438818_6654079773_298, 129 | 0.6735663684_7346836448_5120633247_622, 130 | 0.6268100990_1031741278_8122681624_518, 131 | 0.5776629302_4122296772_3689841612_654, 132 | 0.5263252843_3471918259_9623778158_010, 133 | 0.4730027314_4571496052_2182115009_192, 134 | 0.4178853821_9303774885_1814394594_572, 135 | 0.3611723058_0938783773_5821730127_641, 136 | 0.3030895389_3110783016_7478909980_339, 137 | 0.2438668837_2098843204_5190362797_452, 138 | 0.1837189394_2104889201_5969888759_528, 139 | 0.1228646926_1071039638_7359818808_037, 140 | 0.0615444830_0568507888_6546392366_797, 141 | 0.0000000000_0000000000_0000000000_000]; 142 | // 143 | static immutable Real[26] wgk_ = [ 144 | 0.0019873838_9233031592_6507851882_843, 145 | 0.0055619321_3535671375_8040236901_066, 146 | 0.0094739733_8617415160_7207710523_655, 147 | 0.0132362291_9557167481_3656405846_976, 148 | 0.0168478177_0912829823_1516667536_336, 149 | 0.0204353711_4588283545_6568292235_939, 150 | 0.0240099456_0695321622_0092489164_881, 151 | 0.0274753175_8785173780_2948455517_811, 152 | 0.0307923001_6738748889_1109020215_229, 153 | 0.0340021302_7432933783_6748795229_551, 154 | 0.0371162714_8341554356_0330625367_620, 155 | 0.0400838255_0403238207_4839284467_076, 156 | 0.0428728450_2017004947_6895792439_495, 157 | 0.0455029130_4992178890_9870584752_660, 158 | 0.0479825371_3883671390_6392255756_915, 159 | 0.0502776790_8071567196_3325259433_440, 160 | 0.0523628858_0640747586_4366712137_873, 161 | 0.0542511298_8854549014_4543370459_876, 162 | 0.0559508112_2041231730_8240686382_747, 163 | 0.0574371163_6156783285_3582693939_506, 164 | 0.0586896800_2239420796_1974175856_788, 165 | 0.0597203403_2417405997_9099291932_562, 166 | 0.0605394553_7604586294_5360267517_565, 167 | 0.0611285097_1705304830_5859030416_293, 168 | 0.0614711898_7142531666_1544131965_264, 169 | // note: wgk (26) was calculated from the values of wgk(1..25) 170 | 0.0615808180_6783293507_8759824240_066]; 171 | // 172 | auto fv1 = dimension(fv1_.ptr, 25); 173 | auto fv2 = dimension(fv2_.ptr, 25); 174 | auto xgk = dimension(xgk_.ptr, 26); 175 | auto wgk = dimension(wgk_.ptr, 26); 176 | auto wg = dimension(wg_.ptr, 13); 177 | // 178 | // 179 | // list of major variables 180 | // ----------------------- 181 | // 182 | // centr - mid point of the interval 183 | // hlgth - half-length of the interval 184 | // absc - abscissa 185 | // fval* - function value 186 | // resg - result of the 25-point gauss formula 187 | // resk - result of the 51-point kronrod formula 188 | // reskh - approximation to the mean value of f over (a,b), 189 | // i.e. to i/(b-a) 190 | // 191 | // machine dependent constants 192 | // --------------------------- 193 | // 194 | // epmach is the largest relative spacing. 195 | // uflow is the smallest positive magnitude. 196 | // 197 | //***first executable statement dqk51 198 | epmach = Real.epsilon; 199 | uflow = Real.min_normal; 200 | // 201 | centr = 0.5*(a+b); 202 | hlgth = 0.5*(b-a); 203 | dhlgth = fabs(hlgth); 204 | // 205 | // compute the 51-point kronrod approximation to 206 | // the integral, and estimate the absolute error. 207 | // 208 | fc = f(centr); 209 | resg = wg[13]*fc; 210 | resk = wgk[26]*fc; 211 | resabs = fabs(resk); 212 | for (j=1; j<=12; j++) { //do 10 j=1,12 213 | jtw = j*2; 214 | absc = hlgth*xgk[jtw]; 215 | fval1 = f(centr-absc); 216 | fval2 = f(centr+absc); 217 | fv1[jtw] = fval1; 218 | fv2[jtw] = fval2; 219 | fsum = fval1+fval2; 220 | resg = resg+wg[j]*fsum; 221 | resk = resk+wgk[jtw]*fsum; 222 | resabs = resabs+wgk[jtw]*(fabs(fval1)+fabs(fval2)); 223 | l10: ;} 224 | for (j=1; j<=13; j++) { //do 15 j = 1,13 225 | jtwm1 = j*2-1; 226 | absc = hlgth*xgk[jtwm1]; 227 | fval1 = f(centr-absc); 228 | fval2 = f(centr+absc); 229 | fv1[jtwm1] = fval1; 230 | fv2[jtwm1] = fval2; 231 | fsum = fval1+fval2; 232 | resk = resk+wgk[jtwm1]*fsum; 233 | resabs = resabs+wgk[jtwm1]*(fabs(fval1)+fabs(fval2)); 234 | l15: ;} 235 | reskh = resk*0.5; 236 | resasc = wgk[26]*fabs(fc-reskh); 237 | for (j=1; j<=25; j++) { //do 20 j=1,25 238 | resasc = resasc+wgk[j]*(fabs(fv1[j]-reskh)+fabs(fv2[j]-reskh)); 239 | l20: ;} 240 | result = resk*hlgth; 241 | resabs = resabs*dhlgth; 242 | resasc = resasc*dhlgth; 243 | abserr = fabs((resk-resg)*hlgth); 244 | if(resasc != 0.0 && abserr != 0.0) 245 | abserr = resasc*min(0.1e1,((cast(Real)0.2e3)*abserr/resasc)^^(cast(Real)1.5)); 246 | if(resabs > uflow/(0.5e2*epmach)) abserr = max 247 | ((epmach*0.5e2)*resabs,abserr); 248 | return; 249 | } 250 | 251 | version(unittest) import scid.core.testing; 252 | unittest 253 | { 254 | alias qk51!(float, float delegate(float)) fqk51; 255 | alias qk51!(double, double delegate(double)) dqk51; 256 | alias qk51!(double, double function(double)) dfqk51; 257 | alias qk51!(real, real delegate(real)) rqk51; 258 | 259 | double f(double x) { return x^^3; } 260 | double result, abserr, resabs, resasc; 261 | qk51(&f, 0.0, 1.0, result, abserr, resabs, resasc); 262 | assert (isAccurate(result, abserr, 0.25, 1e-6)); 263 | } 264 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qmomo.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qmomo; 9 | 10 | 11 | import std.math; 12 | import scid.core.fortran; 13 | 14 | 15 | 16 | /// 17 | void qmomo(Real)(Real alfa, Real beta, Real* ri_, Real* rj_, Real* rg_, 18 | Real* rh_, int integr) 19 | { 20 | //***begin prologue dqmomo 21 | //***date written 820101 (yymmdd) 22 | //***revision date 830518 (yymmdd) 23 | //***category no. h2a2a1,c3a2 24 | //***keywords modified chebyshev moments 25 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 26 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 27 | //***purpose this routine computes modified chebsyshev moments. the k-th 28 | // modified chebyshev moment is defined as the integral over 29 | // (-1,1) of w(x)*t(k,x), where t(k,x) is the chebyshev 30 | // polynomial of degree k. 31 | //***description 32 | // 33 | // modified chebyshev moments 34 | // standard fortran subroutine 35 | // double precision version 36 | // 37 | // parameters 38 | // alfa - double precision 39 | // parameter in the weight function w(x), alfa.gt.(-1) 40 | // 41 | // beta - double precision 42 | // parameter in the weight function w(x), beta.gt.(-1) 43 | // 44 | // ri - double precision 45 | // vector of dimension 25 46 | // ri(k) is the integral over (-1,1) of 47 | // (1+x)**alfa*t(k-1,x), k = 1, ..., 25. 48 | // 49 | // rj - double precision 50 | // vector of dimension 25 51 | // rj(k) is the integral over (-1,1) of 52 | // (1-x)**beta*t(k-1,x), k = 1, ..., 25. 53 | // 54 | // rg - double precision 55 | // vector of dimension 25 56 | // rg(k) is the integral over (-1,1) of 57 | // (1+x)**alfa*log((1+x)/2)*t(k-1,x), k = 1, ..., 25. 58 | // 59 | // rh - double precision 60 | // vector of dimension 25 61 | // rh(k) is the integral over (-1,1) of 62 | // (1-x)**beta*log((1-x)/2)*t(k-1,x), k = 1, ..., 25. 63 | // 64 | // integr - integer 65 | // input parameter indicating the modified 66 | // moments to be computed 67 | // integr = 1 compute ri, rj 68 | // = 2 compute ri, rj, rg 69 | // = 3 compute ri, rj, rh 70 | // = 4 compute ri, rj, rg, rh 71 | // 72 | //***references (none) 73 | //***routines called (none) 74 | //***end prologue dqmomo 75 | // 76 | Real alfp1,alfp2,an,anm1,betp1,betp2,ralf,rbet; 77 | int i,im1; 78 | // 79 | auto rg = dimension(rg_, 25); 80 | auto rh = dimension(rh_, 25); 81 | auto ri = dimension(ri_, 25); 82 | auto rj = dimension(rj_, 25); 83 | // 84 | // 85 | //***first executable statement dqmomo 86 | alfp1 = alfa+0.1e1; 87 | betp1 = beta+0.1e1; 88 | alfp2 = alfa+0.2e1; 89 | betp2 = beta+0.2e1; 90 | ralf = (cast(Real)0.2e1)^^alfp1; 91 | rbet = (cast(Real)0.2e1)^^betp1; 92 | // 93 | // compute ri, rj using a forward recurrence relation. 94 | // 95 | ri[1] = ralf/alfp1; 96 | rj[1] = rbet/betp1; 97 | ri[2] = ri[1]*alfa/alfp2; 98 | rj[2] = rj[1]*beta/betp2; 99 | an = 0.2e1; 100 | anm1 = 0.1e1; 101 | for (i=3; i<=25; i++) { //do 20 i=3,25 102 | ri[i] = -(ralf+an*(an-alfp2)*ri[i-1])/(anm1*(an+alfp1)); 103 | rj[i] = -(rbet+an*(an-betp2)*rj[i-1])/(anm1*(an+betp1)); 104 | anm1 = an; 105 | an = an+0.1e1; 106 | l20: ;} 107 | if(integr == 1) goto l70; 108 | if(integr == 3) goto l40; 109 | // 110 | // compute rg using a forward recurrence relation. 111 | // 112 | rg[1] = -ri[1]/alfp1; 113 | rg[2] = -(ralf+ralf)/(alfp2*alfp2)-rg[1]; 114 | an = 0.2e1; 115 | anm1 = 0.1e1; 116 | im1 = 2; 117 | for (i=3; i<=25; i++) { //do 30 i=3,25 118 | rg[i] = -(an*(an-alfp2)*rg[im1]-an*ri[im1]+anm1*ri[i])/ 119 | (anm1*(an+alfp1)); 120 | anm1 = an; 121 | an = an+0.1e1; 122 | im1 = i; 123 | l30: ;} 124 | if(integr == 2) goto l70; 125 | // 126 | // compute rh using a forward recurrence relation. 127 | // 128 | l40: rh[1] = -rj[1]/betp1; 129 | rh[2] = -(rbet+rbet)/(betp2*betp2)-rh[1]; 130 | an = 0.2e1; 131 | anm1 = 0.1e1; 132 | im1 = 2; 133 | for (i=3; i<=25; i++) { //do 50 i=3,25 134 | rh[i] = -(an*(an-betp2)*rh[im1]-an*rj[im1]+ 135 | anm1*rj[i])/(anm1*(an+betp1)); 136 | anm1 = an; 137 | an = an+0.1e1; 138 | im1 = i; 139 | l50: ;} 140 | for (i=2; i<=25; i+=2) { //do 60 i=2,25,2 141 | rh[i] = -rh[i]; 142 | l60: ;} 143 | l70: for (i=2; i<=25; i+=2) { //do 80 i=2,25,2 144 | rj[i] = -rj[i]; 145 | l80: ;} 146 | l90: return; 147 | } 148 | 149 | unittest 150 | { 151 | alias qmomo!float fqmomo; 152 | alias qmomo!double dqmomo; 153 | alias qmomo!real rqmomo; 154 | } 155 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qpsrt.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qpsrt; 9 | 10 | 11 | import scid.core.fortran; 12 | 13 | 14 | 15 | 16 | /// 17 | void qpsrt(Real)(int limit, int last, ref int maxerr, ref Real ermax, 18 | Real* elist_, int* iord_, ref int nrmax) 19 | { 20 | //***begin prologue dqpsrt 21 | //***refer to dqage,dqagie,dqagpe,dqawse 22 | //***routines called (none) 23 | //***revision date 810101 (yymmdd) 24 | //***keywords sequential sorting 25 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 26 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 27 | //***purpose this routine maintains the descending ordering in the 28 | // list of the local error estimated resulting from the 29 | // interval subdivision process. at each call two error 30 | // estimates are inserted using the sequential search 31 | // method, top-down for the largest error estimate and 32 | // bottom-up for the smallest error estimate. 33 | //***description 34 | // 35 | // ordering routine 36 | // standard fortran subroutine 37 | // double precision version 38 | // 39 | // parameters (meaning at output) 40 | // limit - integer 41 | // maximum number of error estimates the list 42 | // can contain 43 | // 44 | // last - integer 45 | // number of error estimates currently in the list 46 | // 47 | // maxerr - integer 48 | // maxerr points to the nrmax-th largest error 49 | // estimate currently in the list 50 | // 51 | // ermax - double precision 52 | // nrmax-th largest error estimate 53 | // ermax = elist(maxerr) 54 | // 55 | // elist - double precision 56 | // vector of dimension last containing 57 | // the error estimates 58 | // 59 | // iord - integer 60 | // vector of dimension last, the first k elements 61 | // of which contain pointers to the error 62 | // estimates, such that 63 | // elist(iord(1)),..., elist(iord(k)) 64 | // form a decreasing sequence, with 65 | // k = last if last.le.(limit/2+2), and 66 | // k = limit+1-last otherwise 67 | // 68 | // nrmax - integer 69 | // maxerr = iord(nrmax) 70 | // 71 | //***end prologue dqpsrt 72 | // 73 | Real errmax,errmin; 74 | int i=1,ibeg=1,ido=1,isucc=1,j=1,jbnd=1,jupbn=1,k=1; 75 | auto elist = dimension(elist_, last); 76 | auto iord = dimension(iord_, last); 77 | // 78 | // check whether the list contains more than 79 | // two error estimates. 80 | // 81 | //***first executable statement dqpsrt 82 | if (last > 2) goto l10; 83 | iord[1] = 1; 84 | iord[2] = 2; 85 | goto l90; 86 | // 87 | // this part of the routine is only executed if, due to a 88 | // difficult integrand, subdivision increased the error 89 | // estimate. in the normal case the insert procedure should 90 | // start after the nrmax-th largest error estimate. 91 | // 92 | l10: errmax = elist[maxerr]; 93 | if (nrmax == 1) goto l30; 94 | ido = nrmax-1; 95 | for (i=1; i<=ido; i++) { // end: l20 96 | isucc = iord[nrmax-1]; 97 | // ***jump out of do-loop 98 | if (errmax <= elist[isucc]) goto l30; 99 | iord[nrmax] = isucc; 100 | nrmax = nrmax-1; 101 | l20:;} 102 | // 103 | // compute the number of elements in the list to be maintained 104 | // in descending order. this number depends on the number of 105 | // subdivisions still allowed. 106 | // 107 | l30: jupbn = last; 108 | if (last > (limit/2+2)) jupbn = limit+3-last; 109 | errmin = elist[last]; 110 | // 111 | // insert errmax by traversing the list top-down, 112 | // starting comparison from the element elist(iord(nrmax+1)). 113 | // 114 | jbnd = jupbn-1; 115 | ibeg = nrmax+1; 116 | if (ibeg > jbnd) goto l50; 117 | for (i=ibeg; i<=jbnd; i++) { // end: l40 118 | isucc = iord[i]; 119 | // ***jump out of do-loop 120 | if (errmax >= elist[isucc]) goto l60; 121 | iord[i-1] = isucc; 122 | l40:;} 123 | l50: iord[jbnd] = maxerr; 124 | iord[jupbn] = last; 125 | goto l90; 126 | // 127 | // insert errmin by traversing the list bottom-up. 128 | // 129 | l60: iord[i-1] = maxerr; 130 | k = jbnd; 131 | for (j=i; j<=jbnd; j++) { // end: l70 132 | isucc = iord[k]; 133 | // ***jump out of do-loop 134 | if (errmin < elist[isucc]) goto l80; 135 | iord[k+1] = isucc; 136 | k = k-1; 137 | l70:;} 138 | iord[i] = last; 139 | goto l90; 140 | l80: iord[k+1] = last; 141 | // 142 | // set maxerr and ermax. 143 | // 144 | l90: maxerr = iord[nrmax]; 145 | ermax = elist[maxerr]; 146 | return; 147 | } 148 | 149 | unittest 150 | { 151 | alias qpsrt!float fqpsrt; 152 | alias qpsrt!double dqpsrt; 153 | alias qpsrt!real rqpsrt; 154 | } 155 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qwgtc.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qwgtc; 9 | 10 | 11 | /// 12 | Real qwgtc(Real)(Real x, Real c, Real p2, Real p3, Real p4, int kp) 13 | { 14 | //***begin prologue dqwgtc 15 | //***refer to dqk15w 16 | //***routines called (none) 17 | //***revision date 810101 (yymmdd) 18 | //***keywords weight function, cauchy principal value 19 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 20 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 21 | //***purpose this function subprogram is used together with the 22 | // routine qawc and defines the weight function. 23 | //***end prologue dqwgtc 24 | // 25 | //***first executable statement dqwgtc 26 | return 1.0/(x-c); 27 | } 28 | 29 | 30 | unittest 31 | { 32 | alias qwgtc!float fqwgtc; 33 | alias qwgtc!double dqwgtc; 34 | alias qwgtc!real rqwgtc; 35 | } 36 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qwgtf.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qwgtf; 9 | 10 | 11 | import std.math: cos, sin; 12 | 13 | 14 | 15 | 16 | /// 17 | Real qwgtf(Real)(Real x, Real omega, Real p2, Real p3, Real p4, int integr) 18 | { 19 | //***begin prologue dqwgtf 20 | //***refer to dqk15w 21 | //***routines called (none) 22 | //***revision date 810101 (yymmdd) 23 | //***keywords cos or sin in weight function 24 | //***author piessens,robert, appl. math. & progr. div. - k.u.leuven 25 | // de doncker,elise,appl. math. * progr. div. - k.u.leuven 26 | //***end prologue dqwgtf 27 | // 28 | //***first executable statement dqwgtf 29 | switch (integr) 30 | { 31 | case 1: return cos(omega*x); 32 | case 2: return sin(omega*x); 33 | default: return Real.nan; 34 | } 35 | } 36 | 37 | 38 | unittest 39 | { 40 | alias qwgtf!float fqwgtf; 41 | alias qwgtf!double dqwgtf; 42 | alias qwgtf!real rqwgtf; 43 | } 44 | -------------------------------------------------------------------------------- /source/scid/ports/quadpack/qwgts.d: -------------------------------------------------------------------------------- 1 | // This code has been mechanically translated from the original FORTRAN 2 | // code at http://netlib.org/quadpack. 3 | 4 | /** Authors: Lars Tandle Kyllingstad 5 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 6 | License: Boost License 1.0 7 | */ 8 | module scid.ports.quadpack.qwgts; 9 | 10 | 11 | import std.math; 12 | 13 | 14 | /// 15 | Real qwgts(Real)(Real x, Real a, Real b, Real alfa, Real beta, int integr) 16 | { 17 | //***begin prologue dqwgts 18 | //***refer to dqk15w 19 | //***routines called (none) 20 | //***revision date 810101 (yymmdd) 21 | //***keywords weight function, algebraico-logarithmic 22 | // end-point singularities 23 | //***author piessens,robert,appl. math. & progr. div. - k.u.leuven 24 | // de doncker,elise,appl. math. & progr. div. - k.u.leuven 25 | //***purpose this function subprogram is used together with the 26 | // routine dqaws and defines the weight function. 27 | //***end prologue dqwgts 28 | // 29 | Real bmx,xma; 30 | //***first executable statement dqwgts 31 | xma = x-a; 32 | bmx = b-x; 33 | Real temp = (xma^^alfa)*(bmx^^beta); 34 | switch (integr) 35 | { 36 | case 1: return temp; 37 | case 2: return temp * log(xma); 38 | case 3: return temp * log(bmx); 39 | case 4: return temp * log(xma)*log(bmx); 40 | default: assert(0); 41 | } 42 | } 43 | 44 | 45 | unittest 46 | { 47 | alias qwgts!float fqwgts; 48 | alias qwgts!double dqwgts; 49 | alias qwgts!real rqwgts; 50 | } 51 | -------------------------------------------------------------------------------- /source/scid/types.d: -------------------------------------------------------------------------------- 1 | /** Various useful types. 2 | 3 | Authors: Lars Tandle Kyllingstad 4 | Copyright: Copyright (c) 2009, Lars T. Kyllingstad. All rights reserved. 5 | License: Boost License 1.0 6 | */ 7 | module scid.types; 8 | 9 | 10 | import std.conv; 11 | import std.format; 12 | import std.math; 13 | import std.string: format; 14 | import std.traits; 15 | 16 | 17 | 18 | 19 | /** Struct containing the result of a calculation, along with 20 | the absolute error in that calculation (x ± δx). 21 | 22 | It is assumed, but not checked, that the error is nonnegative. 23 | */ 24 | struct Result(V, E=V) 25 | { 26 | /// Result. 27 | V value; 28 | alias value this; 29 | 30 | /// Error. 31 | E error; 32 | 33 | invariant() { assert (error >= 0); } 34 | 35 | 36 | 37 | Result opUnary(string op)() const pure nothrow 38 | if (op == "-" || op == "+") 39 | { 40 | mixin ("return Result("~op~"value, error);"); 41 | } 42 | 43 | 44 | /** Operators for Result-Result arithmetic. 45 | 46 | Note that these operations also perform error calculations, and 47 | are thus a bit slower than working directly with the value itself. 48 | It is assumed that the error is much smaller than the value, so 49 | terms of order O(δx δy) or O(δx²) are ignored. 50 | 51 | Also note that multiplication and division are only possible when 52 | the value type V and the error type E are the same (as is the default). 53 | 54 | Through the magic of "alias this", Result!(V, E) is implicitly 55 | castable to the type V, and thus supports the same operations as V 56 | in addition to these. 57 | 58 | */ 59 | Result opBinary(string op)(Result rhs) pure nothrow 60 | if (op == "+" || op == "-") 61 | { 62 | auto lhs = this; 63 | return lhs.opOpAssign!op(rhs); 64 | } 65 | 66 | /// ditto 67 | Result opOpAssign(string op)(Result rhs) pure nothrow 68 | if (op == "+" || op == "-") 69 | { 70 | mixin ("value "~op~"= rhs.value;"); 71 | error += rhs.error; 72 | return this; 73 | } 74 | 75 | 76 | static if (is (V==E)) 77 | { 78 | /// ditto 79 | Result opBinary(string op)(Result rhs) pure nothrow 80 | if (op == "*" || op == "/") 81 | { 82 | auto lhs = this; 83 | return lhs.opOpAssign!op(rhs); 84 | } 85 | 86 | /// ditto 87 | Result opOpAssign(string op)(Result rhs) pure nothrow 88 | if (op == "*") 89 | { 90 | value *= rhs.value; 91 | error = abs(value*rhs.error) + abs(rhs.value*error); 92 | return this; 93 | } 94 | 95 | /// ditto 96 | Result opOpAssign(string op)(Result rhs) pure nothrow 97 | if (op == "/") 98 | { 99 | V inv = 1/rhs.value; 100 | value *= inv; 101 | error = (error + abs(rhs.error*value*inv))*abs(inv); 102 | return this; 103 | } 104 | } 105 | 106 | 107 | /** Get a string representation of the result. */ 108 | void toString(void delegate(const(char)[]) sink, string formatSpec = "%s") 109 | const 110 | { 111 | formattedWrite(sink, formatSpec, value); 112 | sink("\u00B1"); 113 | formattedWrite(sink, formatSpec, error); 114 | } 115 | 116 | /// ditto 117 | string toString(string formatSpec = "%s") const 118 | { 119 | char[] buf; 120 | buf.reserve(100); 121 | void app(const(char)[] s) { buf ~= s; } 122 | toString(&app, formatSpec); 123 | return cast(string) buf; 124 | } 125 | 126 | } 127 | 128 | 129 | unittest 130 | { 131 | alias Result!(real) rr; 132 | alias Result!(real, int) rri; 133 | } 134 | 135 | 136 | unittest 137 | { 138 | auto r1 = Result!double(1.0, 0.1); 139 | auto r2 = Result!double(2.0, 0.2); 140 | 141 | assert (+r1 == r1); 142 | 143 | auto ra = -r1; 144 | assert (ra.value == -1.0); 145 | assert (ra.error == 0.1); 146 | 147 | auto rb = r1 + r2; 148 | assert (abs(rb.value - 3.0) < double.epsilon); 149 | assert (abs(rb.error - 0.3) < double.epsilon); 150 | 151 | auto rc = r1 - r2; 152 | assert (abs(rc.value + 1.0) < double.epsilon); 153 | assert (abs(rc.error - 0.3) < double.epsilon); 154 | 155 | auto rd = r1 * r2; 156 | 157 | auto re = r1 / r2; 158 | } 159 | 160 | 161 | unittest 162 | { 163 | auto r1 = Result!double(1.0, 0.1); 164 | assert (r1.toString() == "1±0.1"); 165 | 166 | auto r2 = Result!double(0.123456789, 0.00123456789); 167 | assert (r2.toString("%.8e") == "1.23456789e-01±1.23456789e-03"); 168 | } 169 | 170 | 171 | 172 | 173 | /** An interval [a,b] along the real line, where either endpoint may 174 | be infinite. 175 | 176 | Examples: 177 | --- 178 | auto i1 = interval(1, 5); 179 | assert (i1.length == 4); 180 | 181 | auto i2 = interval(0, real.infinity); 182 | assert (i2.isInfinite); 183 | --- 184 | */ 185 | struct Interval(T) if (isSigned!T) 186 | { 187 | /** The interval endpoints. */ 188 | T a; 189 | T b; ///ditto 190 | 191 | 192 | pure: // TODO: Mark as nothrow as soon as DMD bug 5191 is fixed (DMD 2.051) 193 | 194 | 195 | /** The length of the interval, defined as b-a. */ 196 | @property T length() @safe const { return b - a; } 197 | 198 | 199 | /** Determine whether the interval is infinite. This is true if: 200 | $(UL 201 | $(LI a is infinite, b is finite) 202 | $(LI a is finite, b is infinite) 203 | $(LI a and b are infinite, but have opposite sign.) 204 | ) 205 | If T is an integer type, this is always false. 206 | */ 207 | @property bool isInfinite() @trusted const 208 | { 209 | static if (isFloatingPoint!T) return isInfinity(length); 210 | else return false; 211 | } 212 | 213 | 214 | /** Determine whether this is an ordered interval, i.e. 215 | whether a <= b. 216 | */ 217 | @property bool isOrdered() @safe const { return a <= b; } 218 | 219 | 220 | /** If a > b, swap the endpoints. */ 221 | void order() @safe 222 | { 223 | if (a > b) 224 | { 225 | immutable tmp = a; 226 | a = b; 227 | b = tmp; 228 | } 229 | } 230 | 231 | 232 | /** Check whether the value x is contained in the interval, 233 | i.e. whether a <= x <= b or b <= x <= a. 234 | */ 235 | bool contains(X)(X x) @safe const 236 | { 237 | return (a <= x && x <= b) || (b <= x && x <= a); 238 | } 239 | } 240 | 241 | 242 | ///ditto 243 | Interval!(CommonType!(T, U)) interval(T, U)(T a, U b) 244 | @safe pure //nothrow 245 | { 246 | return typeof(return)(a, b); 247 | } 248 | 249 | 250 | unittest 251 | { 252 | auto fin = interval(1, 4); 253 | assert (fin.a == 1); 254 | assert (fin.b == 4); 255 | assert (fin.length == 3); 256 | assert (!fin.isInfinite); 257 | assert (fin.isOrdered); 258 | fin.a = 9; 259 | assert (!fin.isOrdered); 260 | fin.order(); 261 | assert (fin.a == 4 && fin.b == 9); 262 | assert (fin.isOrdered); 263 | 264 | auto uin = interval(0.0, real.infinity); 265 | assert (uin.isInfinite); 266 | assert (uin.isOrdered); 267 | } 268 | --------------------------------------------------------------------------------