no message

packages/numlib/Makefile

@@ -0,0 +1,1170 @@
+#
+# Don't edit, this file is generated by FPCMake Version 1.1 [2001/12/18]
+#
+default: all
+override PATH:=$(subst \,/,$(PATH))
+ifeq ($(findstring ;,$(PATH)),)
+inUnix=1
+SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH)))
+else
+SEARCHPATH:=$(subst ;, ,$(PATH))
+endif
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(SEARCHPATH))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(SEARCHPATH))))
+ifeq ($(PWD),)
+nopwd:
+	@echo You need the GNU utils package to use this Makefile!
+	@echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip
+	@exit
+else
+PWD:=$(firstword $(PWD))
+SRCEXEEXT=
+endif
+else
+PWD:=$(firstword $(PWD))
+SRCEXEEXT=.exe
+endif
+ifndef inUnix
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+else
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+else
+ifneq ($(findstring cygwin,$(MACHTYPE)),)
+inCygWin=1
+endif
+endif
+ifeq ($(OS_TARGET),freebsd)
+BSDhier=1
+endif
+ifeq ($(OS_TARGET),netbsd)
+BSDhier=1
+endif
+ifdef inUnix
+BATCHEXT=.sh
+else
+ifdef inOS2
+BATCHEXT=.cmd
+else
+BATCHEXT=.bat
+endif
+endif
+ifdef inUnix
+PATHSEP=/
+else
+PATHSEP:=$(subst /,\,/)
+endif
+ifdef PWD
+BASEDIR:=$(subst \,/,$(shell $(PWD)))
+ifdef inCygWin
+ifneq ($(findstring /cygdrive/,$(BASEDIR)),)
+BASENODIR:=$(patsubst /cygdrive%,%,$(BASEDIR))
+BASEDRIVE:=$(firstword $(subst /, ,$(BASENODIR)))
+BASEDIR:=$(subst /cygdrive/$(BASEDRIVE)/,$(BASEDRIVE):/,$(BASEDIR))
+endif
+endif
+else
+BASEDIR=.
+endif
+ifndef FPC
+ifdef PP
+FPC=$(PP)
+endif
+endif
+ifndef FPC
+FPCPROG:=$(strip $(wildcard $(addsuffix /fpc$(SRCEXEEXT),$(SEARCHPATH))))
+ifneq ($(FPCPROG),)
+FPCPROG:=$(firstword $(FPCPROG))
+FPC:=$(shell $(FPCPROG) -PB)
+ifneq ($(findstring Error,$(FPC)),)
+override FPC=ppc386
+endif
+else
+override FPC=ppc386
+endif
+endif
+override FPC:=$(subst $(SRCEXEEXT),,$(FPC))
+override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT)
+ifndef FPC_VERSION
+FPC_VERSION:=$(shell $(FPC) -iV)
+endif
+export FPC FPC_VERSION
+ifndef CPU_TARGET
+CPU_TARGET:=$(shell $(FPC) -iTP)
+endif
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(shell $(FPC) -iSP)
+endif
+ifndef OS_TARGET
+OS_TARGET:=$(shell $(FPC) -iTO)
+endif
+ifndef OS_SOURCE
+OS_SOURCE:=$(shell $(FPC) -iSO)
+endif
+FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
+FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
+ifneq ($(FULL_TARGET),$(FULL_SOURCE))
+CROSSCOMPILE=1
+endif
+export OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE CROSSCOMPILE
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+ifeq ($(FPCDIR),wrong)
+override FPCDIR=../..
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+ifeq ($(wildcard $(FPCDIR)/units),)
+override FPCDIR=wrong
+endif
+endif
+endif
+ifeq ($(FPCDIR),wrong)
+ifdef inUnix
+override FPCDIR=/usr/local/lib/fpc/$(FPC_VERSION)
+ifeq ($(wildcard $(FPCDIR)/units),)
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+endif
+else
+override FPCDIR:=$(subst /$(FPC),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH))))))
+override FPCDIR:=$(FPCDIR)/..
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR:=$(FPCDIR)/..
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR=c:/pp
+endif
+endif
+endif
+endif
+ifndef CROSSDIR
+CROSSDIR:=$(FPCDIR)/cross/$(FULL_TARGET)
+endif
+ifndef CROSSTARGETDIR
+CROSSTARGETDIR=$(CROSSDIR)/$(FULL_TARGET)
+endif
+ifdef CROSSCOMPILE
+UNITSDIR:=$(wildcard $(CROSSTARGETDIR)/units)
+ifeq ($(UNITSDIR),)
+UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
+endif
+else
+UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
+endif
+PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages)
+override PACKAGE_NAME=numlib
+override PACKAGE_VERSION=1.0.5
+override TARGET_UNITS+=typ omv dsl mdt det eig eigh1 eigh2 int inv iom ipf ode roo sle spe spl numlib tpnumlib
+override INSTALL_FPCPACKAGE=y
+ifdef REQUIRE_UNITSDIR
+override UNITSDIR+=$(REQUIRE_UNITSDIR)
+endif
+ifdef REQUIRE_PACKAGESDIR
+override PACKAGESDIR+=$(REQUIRE_PACKAGESDIR)
+endif
+ifdef ZIPINSTALL
+ifeq ($(OS_TARGET),linux)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),freebsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),netbsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),sunos)
+UNIXINSTALLDIR=1
+endif
+else
+ifeq ($(OS_SOURCE),linux)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_SOURCE),freebsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_SOURCE),netbsd)
+UNIXINSTALLDIR=1
+endif
+ifeq ($(OS_TARGET),sunos)
+UNIXINSTALLDIR=1
+endif
+endif
+ifndef INSTALL_PREFIX
+ifdef UNIXINSTALLDIR
+INSTALL_PREFIX=/usr/local
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_BASEDIR:=/pp
+else
+INSTALL_BASEDIR:=/$(PACKAGE_NAME)
+endif
+endif
+endif
+export INSTALL_PREFIX
+ifndef DIST_DESTDIR
+DIST_DESTDIR:=$(BASEDIR)
+endif
+export DIST_DESTDIR
+ifndef INSTALL_BASEDIR
+ifdef UNIXINSTALLDIR
+ifdef INSTALL_FPCPACKAGE
+INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/fpc/$(FPC_VERSION)
+else
+INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/$(PACKAGE_NAME)
+endif
+else
+INSTALL_BASEDIR:=$(INSTALL_PREFIX)
+endif
+endif
+ifndef INSTALL_BINDIR
+ifdef UNIXINSTALLDIR
+INSTALL_BINDIR:=$(INSTALL_PREFIX)/bin
+else
+INSTALL_BINDIR:=$(INSTALL_BASEDIR)/bin
+ifdef INSTALL_FPCPACKAGE
+INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(OS_TARGET)
+endif
+endif
+endif
+ifndef INSTALL_UNITDIR
+ifdef CROSSCOMPILE
+INSTALL_UNITDIR:=$(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/units
+else
+INSTALL_UNITDIR:=$(INSTALL_BASEDIR)/units/$(OS_TARGET)
+endif
+ifdef INSTALL_FPCPACKAGE
+ifdef PACKAGE_NAME
+INSTALL_UNITDIR:=$(INSTALL_UNITDIR)/$(PACKAGE_NAME)
+endif
+endif
+endif
+ifndef INSTALL_LIBDIR
+ifdef UNIXINSTALLDIR
+INSTALL_LIBDIR:=$(INSTALL_PREFIX)/lib
+else
+INSTALL_LIBDIR:=$(INSTALL_UNITDIR)
+endif
+endif
+ifndef INSTALL_SOURCEDIR
+ifdef UNIXINSTALLDIR
+ifdef INSTALL_FPCPACKAGE
+ifdef BSDhier
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/share/src/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+else
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/src/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+endif
+else
+ifdef BSDhier
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/share/src/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+else
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/src/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+endif
+endif
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source/$(PACKAGE_NAME)
+else
+INSTALL_SOURCEDIRL:=$(INSTALL_BASEDIR)/source
+endif
+endif
+endif
+ifndef INSTALL_DOCDIR
+ifdef UNIXINSTALLDIR
+ifdef INSTALL_FPCPACKAGE
+ifdef BSDhier
+INSTALL_DOCDIR:=$(INSTALL_PREFIX)/share/doc/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+else
+INSTALL_DOCDIR:=$(INSTALL_PREFIX)/doc/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+endif
+else
+ifdef BSDhier
+INSTALL_DOCDIR:=$(INSTALL_PREFIX)/share/doc/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+else
+INSTALL_DOCDIR:=$(INSTALL_PREFIX)/doc/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+endif
+endif
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc/$(PACKAGE_NAME)
+else
+INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc
+endif
+endif
+endif
+ifndef INSTALL_EXAMPLEDIR
+ifdef UNIXINSTALLDIR
+ifdef INSTALL_FPCPACKAGE
+ifdef BSDhier
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+else
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/fpc-$(FPC_VERSION)/examples/$(PACKAGE_NAME)
+endif
+else
+ifdef BSDhier
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+else
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+endif
+endif
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples/$(PACKAGE_NAME)
+else
+INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples
+endif
+endif
+endif
+ifndef INSTALL_DATADIR
+INSTALL_DATADIR=$(INSTALL_BASEDIR)
+endif
+ifdef CROSSCOMPILE
+ifndef CROSSBINDIR
+CROSSBINDIR:=$(wildcard $(CROSSTARGETDIR)/bin/$(FULL_SOURCE))
+ifeq ($(CROSSBINDIR),)
+CROSSBINDIR:=$(wildcard $(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/bin/$(FULL_SOURCE))
+endif
+endif
+else
+CROSSBINDIR=
+endif
+LOADEREXT=.as
+EXEEXT=.exe
+PPLEXT=.ppl
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.so
+STATICLIBPREFIX=libp
+RSTEXT=.rst
+FPCMADE=fpcmade
+ifeq ($(OS_TARGET),go32v1)
+PPUEXT=.pp1
+OEXT=.o1
+ASMEXT=.s1
+SMARTEXT=.sl1
+STATICLIBEXT=.a1
+SHAREDLIBEXT=.so1
+STATICLIBPREFIX=
+FPCMADE=fpcmade.v1
+PACKAGESUFFIX=v1
+endif
+ifeq ($(OS_TARGET),go32v2)
+STATICLIBPREFIX=
+FPCMADE=fpcmade.dos
+ZIPSUFFIX=go32
+endif
+ifeq ($(OS_TARGET),linux)
+EXEEXT=
+HASSHAREDLIB=1
+FPCMADE=fpcmade.lnx
+ZIPSUFFIX=linux
+endif
+ifeq ($(OS_TARGET),freebsd)
+EXEEXT=
+HASSHAREDLIB=1
+FPCMADE=fpcmade.freebsd
+ZIPSUFFIX=freebsd
+endif
+ifeq ($(OS_TARGET),netbsd)
+EXEEXT=
+HASSHAREDLIB=1
+FPCMADE=fpcmade.netbsd
+ZIPSUFFIX=netbsd
+endif
+ifeq ($(OS_TARGET),win32)
+PPUEXT=.ppw
+OEXT=.ow
+ASMEXT=.sw
+SMARTEXT=.slw
+STATICLIBEXT=.aw
+SHAREDLIBEXT=.dll
+FPCMADE=fpcmade.w32
+ZIPSUFFIX=w32
+endif
+ifeq ($(OS_TARGET),os2)
+PPUEXT=.ppo
+ASMEXT=.so2
+OEXT=.oo2
+AOUTEXT=.out
+SMARTEXT=.so
+STATICLIBEXT=.ao2
+SHAREDLIBEXT=.dll
+FPCMADE=fpcmade.os2
+ZIPSUFFIX=emx
+endif
+ifeq ($(OS_TARGET),amiga)
+EXEEXT=
+PPUEXT=.ppa
+ASMEXT=.asm
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.library
+FPCMADE=fpcmade.amg
+endif
+ifeq ($(OS_TARGET),atari)
+PPUEXT=.ppt
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=.ttp
+FPCMADE=fpcmade.ata
+endif
+ifeq ($(OS_TARGET),beos)
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+FPCMADE=fpcmade.be
+ZIPSUFFIX=be
+endif
+ifeq ($(OS_TARGET),sunos)
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+FPCMADE=fpcmade.sun
+ZIPSUFFIX=sun
+endif
+ifeq ($(OS_TARGET),qnx)
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+FPCMADE=fpcmade.qnx
+ZIPSUFFIX=qnx
+endif
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO=
+else
+ECHO:=$(firstword $(ECHO))
+endif
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+ifndef DATE
+DATE:=$(strip $(wildcard $(addsuffix /gdate$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE:=$(strip $(wildcard $(addsuffix /date$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE=
+else
+DATE:=$(firstword $(DATE))
+endif
+else
+DATE:=$(firstword $(DATE))
+endif
+endif
+export DATE
+ifndef GINSTALL
+GINSTALL:=$(strip $(wildcard $(addsuffix /ginstall$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(GINSTALL),)
+GINSTALL:=$(strip $(wildcard $(addsuffix /install$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(GINSTALL),)
+GINSTALL=
+else
+GINSTALL:=$(firstword $(GINSTALL))
+endif
+else
+GINSTALL:=$(firstword $(GINSTALL))
+endif
+endif
+export GINSTALL
+ifndef CPPROG
+CPPROG:=$(strip $(wildcard $(addsuffix /cp$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(CPPROG),)
+CPPROG=
+else
+CPPROG:=$(firstword $(CPPROG))
+endif
+endif
+export CPPROG
+ifndef RMPROG
+RMPROG:=$(strip $(wildcard $(addsuffix /rm$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(RMPROG),)
+RMPROG=
+else
+RMPROG:=$(firstword $(RMPROG))
+endif
+endif
+export RMPROG
+ifndef MVPROG
+MVPROG:=$(strip $(wildcard $(addsuffix /mv$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(MVPROG),)
+MVPROG=
+else
+MVPROG:=$(firstword $(MVPROG))
+endif
+endif
+export MVPROG
+ifndef ECHOREDIR
+ECHOREDIR:=$(subst /,$(PATHSEP),$(ECHO))
+endif
+ifndef COPY
+COPY:=$(CPPROG) -fp
+endif
+ifndef COPYTREE
+COPYTREE:=$(CPPROG) -rfp
+endif
+ifndef MOVE
+MOVE:=$(MVPROG) -f
+endif
+ifndef DEL
+DEL:=$(RMPROG) -f
+endif
+ifndef DELTREE
+DELTREE:=$(RMPROG) -rf
+endif
+ifndef INSTALL
+ifdef inUnix
+INSTALL:=$(GINSTALL) -c -m 644
+else
+INSTALL:=$(COPY)
+endif
+endif
+ifndef INSTALLEXE
+ifdef inUnix
+INSTALLEXE:=$(GINSTALL) -c -m 755
+else
+INSTALLEXE:=$(COPY)
+endif
+endif
+ifndef MKDIR
+MKDIR:=$(GINSTALL) -m 755 -d
+endif
+export ECHOREDIR COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR
+ifndef PPUMOVE
+PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUMOVE),)
+PPUMOVE=
+else
+PPUMOVE:=$(firstword $(PPUMOVE))
+endif
+endif
+export PPUMOVE
+ifndef FPCMAKE
+FPCMAKE:=$(strip $(wildcard $(addsuffix /fpcmake$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(FPCMAKE),)
+FPCMAKE=
+else
+FPCMAKE:=$(firstword $(FPCMAKE))
+endif
+endif
+export FPCMAKE
+ifndef ZIPPROG
+ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ZIPPROG),)
+ZIPPROG=
+else
+ZIPPROG:=$(firstword $(ZIPPROG))
+endif
+endif
+export ZIPPROG
+ifndef TARPROG
+TARPROG:=$(strip $(wildcard $(addsuffix /tar$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(TARPROG),)
+TARPROG=
+else
+TARPROG:=$(firstword $(TARPROG))
+endif
+endif
+export TARPROG
+ASNAME=as
+LDNAME=ld
+ARNAME=ar
+RCNAME=rc
+ifeq ($(OS_TARGET),win32)
+ASNAME=asw
+LDNAME=ldw
+ARNAME=arw
+endif
+ifndef ASPROG
+ifdef CROSSBINDIR
+ASPROG=$(CROSSBINDIR)/$(ASNAME)$(SRCEXEEXT)
+else
+ASPROG=$(ASNAME)
+endif
+endif
+ifndef LDPROG
+ifdef CROSSBINDIR
+LDPROG=$(CROSSBINDIR)/$(LDNAME)$(SRCEXEEXT)
+else
+LDPROG=$(LDNAME)
+endif
+endif
+ifndef RCPROG
+ifdef CROSSBINDIR
+RCPROG=$(CROSSBINDIR)/$(RCNAME)$(SRCEXEEXT)
+else
+RCPROG=$(RCNAME)
+endif
+endif
+ifndef ARPROG
+ifdef CROSSBINDIR
+ARPROG=$(CROSSBINDIR)/$(ARNAME)$(SRCEXEEXT)
+else
+ARPROG=$(ARNAME)
+endif
+endif
+AS=$(ASPROG)
+LD=$(LDPROG)
+RC=$(RCPROG)
+AR=$(ARPROG)
+PPAS=ppas$(BATCHEXT)
+ifdef inUnix
+LDCONFIG=ldconfig
+else
+LDCONFIG=
+endif
+ifdef DATE
+DATESTR:=$(shell $(DATE) +%Y%m%d)
+else
+DATESTR=
+endif
+ifndef UPXPROG
+ifeq ($(OS_TARGET),go32v2)
+UPXPROG:=1
+endif
+ifeq ($(OS_TARGET),win32)
+UPXPROG:=1
+endif
+ifdef UPXPROG
+UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(UPXPROG),)
+UPXPROG=
+else
+UPXPROG:=$(firstword $(UPXPROG))
+endif
+else
+UPXPROG=
+endif
+endif
+export UPXPROG
+ZIPOPT=-9
+ZIPEXT=.zip
+ifeq ($(USETAR),bz2)
+TAROPT=vI
+TAREXT=.tar.bz2
+else
+TAROPT=vz
+TAREXT=.tar.gz
+endif
+ifeq ($(OS_TARGET),linux)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),go32v2)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),win32)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),os2)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),freebsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),beos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),netbsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),amiga)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),atari)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),sunos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(OS_TARGET),qnx)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifdef REQUIRE_PACKAGES_RTL
+PACKAGEDIR_RTL:=$(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR)))))
+ifneq ($(PACKAGEDIR_RTL),)
+PACKAGEDIR_RTL:=$(firstword $(PACKAGEDIR_RTL))
+ifeq ($(wildcard $(PACKAGEDIR_RTL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=package_rtl
+package_rtl:
+	$(MAKE) -C $(PACKAGEDIR_RTL) all
+endif
+ifneq ($(wildcard $(PACKAGEDIR_RTL)/$(OS_TARGET)),)
+UNITDIR_RTL=$(PACKAGEDIR_RTL)/$(OS_TARGET)
+else
+UNITDIR_RTL=$(PACKAGEDIR_RTL)
+endif
+else
+PACKAGEDIR_RTL=
+UNITDIR_RTL:=$(subst /Package.fpc,,$(strip $(wildcard $(addsuffix /rtl/Package.fpc,$(UNITSDIR)))))
+ifneq ($(UNITDIR_RTL),)
+UNITDIR_RTL:=$(firstword $(UNITDIR_RTL))
+else
+UNITDIR_RTL=
+endif
+endif
+ifdef UNITDIR_RTL
+override COMPILER_UNITDIR+=$(UNITDIR_RTL)
+endif
+endif
+.PHONY: package_rtl
+ifndef NOCPUDEF
+override FPCOPTDEF=$(CPU_TARGET)
+endif
+ifneq ($(OS_TARGET),$(OS_SOURCE))
+override FPCOPT+=-T$(OS_TARGET)
+endif
+ifdef UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
+endif
+ifdef LIBDIR
+override FPCOPT+=$(addprefix -Fl,$(LIBDIR))
+endif
+ifdef OBJDIR
+override FPCOPT+=$(addprefix -Fo,$(OBJDIR))
+endif
+ifdef INCDIR
+override FPCOPT+=$(addprefix -Fi,$(INCDIR))
+endif
+ifdef LINKSMART
+override FPCOPT+=-XX
+endif
+ifdef CREATESMART
+override FPCOPT+=-CX
+endif
+ifdef DEBUG
+override FPCOPT+=-gl
+override FPCOPTDEF+=DEBUG
+endif
+ifdef RELEASE
+ifeq ($(CPU_TARGET),i386)
+FPCCPUOPT:=-OG2p3
+else
+FPCCPUOPT:=
+endif
+override FPCOPT+=-Xs $(FPCCPUOPT) -n
+override FPCOPTDEF+=RELEASE
+endif
+ifdef STRIP
+override FPCOPT+=-Xs
+endif
+ifdef OPTIMIZE
+ifeq ($(CPU_TARGET),i386)
+override FPCOPT+=-OG2p3
+endif
+endif
+ifdef VERBOSE
+override FPCOPT+=-vwni
+endif
+ifdef COMPILER_OPTIONS
+override FPCOPT+=$(COMPILER_OPTIONS)
+endif
+ifdef COMPILER_UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(COMPILER_UNITDIR))
+endif
+ifdef COMPILER_LIBRARYDIR
+override FPCOPT+=$(addprefix -Fl,$(COMPILER_LIBRARYDIR))
+endif
+ifdef COMPILER_OBJECTDIR
+override FPCOPT+=$(addprefix -Fo,$(COMPILER_OBJECTDIR))
+endif
+ifdef COMPILER_INCLUDEDIR
+override FPCOPT+=$(addprefix -Fi,$(COMPILER_INCLUDEDIR))
+endif
+ifdef CROSSBINDIR
+override FPCOPT+=-FD$(CROSSBINDIR)
+endif
+ifdef COMPILER_TARGETDIR
+override FPCOPT+=-FE$(COMPILER_TARGETDIR)
+ifeq ($(COMPILER_TARGETDIR),.)
+override TARGETDIRPREFIX=
+else
+override TARGETDIRPREFIX=$(COMPILER_TARGETDIR)/
+endif
+endif
+ifdef COMPILER_UNITTARGETDIR
+override FPCOPT+=-FU$(COMPILER_UNITTARGETDIR)
+ifeq ($(COMPILER_UNITTARGETDIR),.)
+override UNITTARGETDIRPREFIX=
+else
+override UNITTARGETDIRPREFIX=$(COMPILER_UNITTARGETDIR)/
+endif
+else
+ifdef COMPILER_TARGETDIR
+override COMPILER_UNITTARGETDIR=$(COMPILER_TARGETDIR)
+override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX)
+endif
+endif
+ifdef OPT
+override FPCOPT+=$(OPT)
+endif
+ifdef FPCOPTDEF
+override FPCOPT+=$(addprefix -d,$(FPCOPTDEF))
+endif
+ifdef CFGFILE
+override FPCOPT+=@$(CFGFILE)
+endif
+ifdef USEENV
+override FPCEXTCMD:=$(FPCOPT)
+override FPCOPT:=!FPCEXTCMD
+export FPCEXTCMD
+endif
+override COMPILER:=$(FPC) $(FPCOPT)
+ifeq (,$(findstring -s ,$(COMPILER)))
+EXECPPAS=
+else
+ifeq ($(OS_SOURCE),$(OS_TARGET))
+EXECPPAS:=@$(PPAS)
+endif
+endif
+.PHONY: fpc_units
+ifdef TARGET_UNITS
+override ALLTARGET+=fpc_units
+override UNITPPUFILES=$(addsuffix $(PPUEXT),$(TARGET_UNITS))
+override INSTALLPPUFILES+=$(UNITPPUFILES)
+override CLEANPPUFILES+=$(UNITPPUFILES)
+endif
+fpc_units: $(UNITPPUFILES)
+ifdef TARGET_RSTS
+override RSTFILES=$(addsuffix $(RSTEXT),$(TARGET_RSTS))
+override CLEANRSTFILES+=$(RSTFILES)
+endif
+.PHONY: fpc_packages fpc_all fpc_smart fpc_debug
+$(FPCMADE): $(ALLTARGET)
+	@$(ECHOREDIR) Compiled > $(FPCMADE)
+fpc_packages: $(COMPILEPACKAGES)
+fpc_all: fpc_packages $(FPCMADE)
+fpc_smart:
+	$(MAKE) all LINKSMART=1 CREATESMART=1
+fpc_debug:
+	$(MAKE) all DEBUG=1
+.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp
+%$(PPUEXT): %.pp
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(PPUEXT): %.pas
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(EXEEXT): %.pp
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(EXEEXT): %.pas
+	$(COMPILER) $<
+	$(EXECPPAS)
+vpath %.pp $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
+vpath %.pas $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
+vpath %$(PPUEXT) $(COMPILER_UNITTARGETDIR)
+.PHONY: fpc_install fpc_sourceinstall fpc_exampleinstall
+ifdef INSTALL_UNITS
+override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(INSTALL_UNITS))
+endif
+ifdef INSTALLPPUFILES
+override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))
+override INSTALLPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPUFILES))
+override INSTALLPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPULINKFILES)))
+override INSTALL_CREATEPACKAGEFPC=1
+endif
+ifdef INSTALLEXEFILES
+override INSTALLEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(INSTALLEXEFILES))
+endif
+fpc_install: all $(INSTALLTARGET)
+ifdef INSTALLEXEFILES
+	$(MKDIR) $(INSTALL_BINDIR)
+ifdef UPXPROG
+	-$(UPXPROG) $(INSTALLEXEFILES)
+endif
+	$(INSTALLEXE) $(INSTALLEXEFILES) $(INSTALL_BINDIR)
+endif
+ifdef INSTALL_CREATEPACKAGEFPC
+ifdef FPCMAKE
+ifdef PACKAGE_VERSION
+ifneq ($(wildcard Makefile.fpc),)
+	$(FPCMAKE) -p -T$(OS_TARGET) Makefile.fpc
+	$(MKDIR) $(INSTALL_UNITDIR)
+	$(INSTALL) Package.fpc $(INSTALL_UNITDIR)
+endif
+endif
+endif
+endif
+ifdef INSTALLPPUFILES
+	$(MKDIR) $(INSTALL_UNITDIR)
+	$(INSTALL) $(INSTALLPPUFILES) $(INSTALL_UNITDIR)
+ifneq ($(INSTALLPPULINKFILES),)
+	$(INSTALL) $(INSTALLPPULINKFILES) $(INSTALL_UNITDIR)
+endif
+ifneq ($(wildcard $(LIB_FULLNAME)),)
+	$(MKDIR) $(INSTALL_LIBDIR)
+	$(INSTALL) $(LIB_FULLNAME) $(INSTALL_LIBDIR)
+ifdef inUnix
+	ln -sf $(LIB_FULLNAME) $(INSTALL_LIBDIR)/$(LIB_NAME)
+endif
+endif
+endif
+ifdef INSTALL_FILES
+	$(MKDIR) $(INSTALL_DATADIR)
+	$(INSTALL) $(INSTALL_FILES) $(INSTALL_DATADIR)
+endif
+fpc_sourceinstall: distclean
+	$(MKDIR) $(INSTALL_SOURCEDIR)
+	$(COPYTREE) $(BASEDIR) $(INSTALL_SOURCEDIR)
+fpc_exampleinstall: $(addsuffix _distclean,$(TARGET_EXAMPLEDIRS))
+ifdef HASEXAMPLES
+	$(MKDIR) $(INSTALL_EXAMPLEDIR)
+endif
+ifdef EXAMPLESOURCEFILES
+	$(COPY) $(EXAMPLESOURCEFILES) $(INSTALL_EXAMPLEDIR)
+endif
+ifdef TARGET_EXAMPLEDIRS
+	$(COPYTREE) $(addsuffix /*,$(TARGET_EXAMPLEDIRS)) $(INSTALL_EXAMPLEDIR)
+endif
+.PHONY: fpc_distinstall
+fpc_distinstall: install exampleinstall
+.PHONY: fpc_zipinstall fpc_zipsourceinstall fpc_zipexampleinstall
+ifndef PACKDIR
+ifndef inUnix
+PACKDIR=$(BASEDIR)/../fpc-pack
+else
+PACKDIR=/tmp/fpc-pack
+endif
+endif
+ifndef ZIPNAME
+ifdef DIST_ZIPNAME
+ZIPNAME=$(DIST_ZIPNAME)
+else
+ZIPNAME=$(ZIPPREFIX)$(PACKAGE_NAME)$(ZIPSUFFIX)
+endif
+endif
+ifndef ZIPTARGET
+ifdef DIST_ZIPTARGET
+ZIPTARGET=DIST_ZIPTARGET
+else
+ZIPTARGET=install
+endif
+endif
+ifndef USEZIP
+ifdef inUnix
+USETAR=1
+endif
+endif
+ifndef inUnix
+USEZIPWRAPPER=1
+endif
+ifdef USEZIPWRAPPER
+ZIPPATHSEP=$(PATHSEP)
+ZIPWRAPPER=$(subst /,$(PATHSEP),$(DIST_DESTDIR)/fpczip$(BATCHEXT))
+else
+ZIPPATHSEP=/
+endif
+ZIPCMD_CDPACK:=cd $(subst /,$(ZIPPATHSEP),$(PACKDIR))
+ZIPCMD_CDBASE:=cd $(subst /,$(ZIPPATHSEP),$(BASEDIR))
+ifdef USETAR
+ZIPDESTFILE:=$(DIST_DESTDIR)/$(ZIPNAME)$(TAREXT)
+ZIPCMD_ZIP:=$(TARPROG) cf$(TAROPT) $(ZIPDESTFILE) *
+else
+ZIPDESTFILE:=$(DIST_DESTDIR)/$(ZIPNAME)$(ZIPEXT)
+ZIPCMD_ZIP:=$(subst /,$(ZIPPATHSEP),$(ZIPPROG)) -Dr $(ZIPOPT) $(ZIPDESTFILE) *
+endif
+fpc_zipinstall:
+	$(MAKE) $(ZIPTARGET) INSTALL_PREFIX=$(PACKDIR) ZIPINSTALL=1
+	$(MKDIR) $(DIST_DESTDIR)
+	$(DEL) $(ZIPDESTFILE)
+ifdef USEZIPWRAPPER
+ifneq ($(ECHOREDIR),echo)
+	$(ECHOREDIR) -e "$(subst \,\\,$(ZIPCMD_CDPACK))" > $(ZIPWRAPPER)
+	$(ECHOREDIR) -e "$(subst \,\\,$(ZIPCMD_ZIP))" >> $(ZIPWRAPPER)
+	$(ECHOREDIR) -e "$(subst \,\\,$(ZIPCMD_CDBASE))" >> $(ZIPWRAPPER)
+else
+	echo $(ZIPCMD_CDPACK) > $(ZIPWRAPPER)
+	echo $(ZIPCMD_ZIP) >> $(ZIPWRAPPER)
+	echo $(ZIPCMD_CDBASE) >> $(ZIPWRAPPER)
+endif
+ifdef inUnix
+	/bin/sh $(ZIPWRAPPER)
+else
+	$(ZIPWRAPPER)
+endif
+	$(DEL) $(ZIPWRAPPER)
+else
+	$(ZIPCMD_CDPACK) ; $(ZIPCMD_ZIP) ; $(ZIPCMD_CDBASE)
+endif
+	$(DELTREE) $(PACKDIR)
+fpc_zipsourceinstall:
+	$(MAKE) fpc_zipinstall ZIPTARGET=sourceinstall ZIPSUFFIX=src
+fpc_zipexampleinstall:
+ifdef HASEXAMPLES
+	$(MAKE) fpc_zipinstall ZIPTARGET=exampleinstall ZIPSUFFIX=exm
+endif
+fpc_zipdistinstall:
+	$(MAKE) fpc_zipinstall ZIPTARGET=distinstall
+.PHONY: fpc_clean fpc_cleanall fpc_distclean
+ifdef EXEFILES
+override CLEANEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(CLEANEXEFILES))
+endif
+ifdef CLEAN_UNITS
+override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(CLEAN_UNITS))
+endif
+ifdef CLEANPPUFILES
+override CLEANPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES)))
+override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES))
+override CLEANPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES)))
+endif
+fpc_clean: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+ifdef CLEANPPUFILES
+	-$(DEL) $(CLEANPPUFILES)
+endif
+ifneq ($(CLEANPPULINKFILES),)
+	-$(DEL) $(CLEANPPULINKFILES)
+endif
+ifdef CLEANRSTFILES
+	-$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES))
+endif
+ifdef CLEAN_FILES
+	-$(DEL) $(CLEAN_FILES)
+endif
+ifdef LIB_NAME
+	-$(DEL) $(LIB_NAME) $(LIB_FULLNAME)
+endif
+	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
+fpc_distclean: clean
+ifdef COMPILER_UNITTARGETDIR
+TARGETDIRCLEAN=fpc_clean
+endif
+fpc_cleanall: $(CLEANTARGET) $(TARGETDIRCLEAN)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+	-$(DELTREE) *$(SMARTEXT)
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE)
+ifdef AOUTEXT
+	-$(DEL) *$(AOUTEXT)
+endif
+.PHONY: fpc_info
+fpc_info:
+	@$(ECHO)
+	@$(ECHO)  == Package info ==
+	@$(ECHO)  Package Name..... $(PACKAGE_NAME)
+	@$(ECHO)  Package Version.. $(PACKAGE_VERSION)
+	@$(ECHO)
+	@$(ECHO)  == Configuration info ==
+	@$(ECHO)
+	@$(ECHO)  FPC.......... $(FPC)
+	@$(ECHO)  FPC Version.. $(FPC_VERSION)
+	@$(ECHO)  Source CPU... $(CPU_SOURCE)
+	@$(ECHO)  Target CPU... $(CPU_TARGET)
+	@$(ECHO)  Source OS.... $(OS_SOURCE)
+	@$(ECHO)  Target OS.... $(OS_TARGET)
+	@$(ECHO)  Full Target.. $(FULL_SOURCE)
+	@$(ECHO)  Full Source.. $(FULL_TARGET)
+	@$(ECHO)
+	@$(ECHO)  == Directory info ==
+	@$(ECHO)
+	@$(ECHO)  Basedir......... $(BASEDIR)
+	@$(ECHO)  FPCDir.......... $(FPCDIR)
+	@$(ECHO)  CrossBinDir..... $(CROSSBINDIR)
+	@$(ECHO)  UnitsDir........ $(UNITSDIR)
+	@$(ECHO)  PackagesDir..... $(PACKAGESDIR)
+	@$(ECHO)
+	@$(ECHO)  GCC library..... $(GCCLIBDIR)
+	@$(ECHO)  Other library... $(OTHERLIBDIR)
+	@$(ECHO)
+	@$(ECHO)  == Tools info ==
+	@$(ECHO)
+	@$(ECHO)  As........ $(AS)
+	@$(ECHO)  Ld........ $(LD)
+	@$(ECHO)  Ar........ $(AR)
+	@$(ECHO)  Rc........ $(RC)
+	@$(ECHO)  
+	@$(ECHO)  Mv........ $(MVPROG)
+	@$(ECHO)  Cp........ $(CPPROG)
+	@$(ECHO)  Rm........ $(RMPROG)
+	@$(ECHO)  GInstall.. $(GINSTALL)
+	@$(ECHO)  Echo...... $(ECHO)
+	@$(ECHO)  Date...... $(DATE)
+	@$(ECHO)  FPCMake... $(FPCMAKE)
+	@$(ECHO)  PPUMove... $(PPUMOVE)
+	@$(ECHO)  Upx....... $(UPXPROG)
+	@$(ECHO)  Zip....... $(ZIPPROG)
+	@$(ECHO)
+	@$(ECHO)  == Object info ==
+	@$(ECHO)
+	@$(ECHO)  Target Loaders...... $(TARGET_LOADERS)
+	@$(ECHO)  Target Units........ $(TARGET_UNITS)
+	@$(ECHO)  Target Programs..... $(TARGET_PROGRAMS)
+	@$(ECHO)  Target Dirs......... $(TARGET_DIRS)
+	@$(ECHO)  Target Examples..... $(TARGET_EXAMPLES)
+	@$(ECHO)  Target ExampleDirs.. $(TARGET_EXAMPLEDIRS)
+	@$(ECHO)
+	@$(ECHO)  Clean Units......... $(CLEAN_UNITS)
+	@$(ECHO)  Clean Files......... $(CLEAN_FILES)
+	@$(ECHO)
+	@$(ECHO)  Install Units....... $(INSTALL_UNITS)
+	@$(ECHO)  Install Files....... $(INSTALL_FILES)
+	@$(ECHO)
+	@$(ECHO)  == Install info ==
+	@$(ECHO)
+	@$(ECHO)  DateStr.............. $(DATESTR)
+	@$(ECHO)  ZipPrefix............ $(ZIPPREFIX)
+	@$(ECHO)  ZipSuffix............ $(ZIPSUFFIX)
+	@$(ECHO)  Install FPC Package.. $(INSTALL_FPCPACKAGE)
+	@$(ECHO)
+	@$(ECHO)  Install base dir..... $(INSTALL_BASEDIR)
+	@$(ECHO)  Install binary dir... $(INSTALL_BINDIR)
+	@$(ECHO)  Install library dir.. $(INSTALL_LIBDIR)
+	@$(ECHO)  Install units dir.... $(INSTALL_UNITDIR)
+	@$(ECHO)  Install source dir... $(INSTALL_SOURCEDIR)
+	@$(ECHO)  Install doc dir...... $(INSTALL_DOCDIR)
+	@$(ECHO)  Install example dir.. $(INSTALL_EXAMPLEDIR)
+	@$(ECHO)  Install data dir..... $(INSTALL_DATADIR)
+	@$(ECHO)
+	@$(ECHO)  Dist destination dir. $(DIST_DESTDIR)
+	@$(ECHO)  Dist zip name........ $(DIST_ZIPNAME)
+	@$(ECHO)
+all: fpc_all
+debug: fpc_debug
+smart: fpc_smart
+examples:
+shared:
+install: fpc_install
+sourceinstall: fpc_sourceinstall
+exampleinstall: fpc_exampleinstall
+distinstall: fpc_distinstall
+zipinstall: fpc_zipinstall
+zipsourceinstall: fpc_zipsourceinstall
+zipexampleinstall: fpc_zipexampleinstall
+zipdistinstall: fpc_zipdistinstall
+clean: fpc_clean
+distclean: fpc_distclean
+cleanall: fpc_cleanall
+info: fpc_info
+.PHONY: all debug smart examples shared install sourceinstall exampleinstall distinstall zipinstall zipsourceinstall zipexampleinstall zipdistinstall clean distclean cleanall info
+ifneq ($(wildcard fpcmake.loc),)
+include fpcmake.loc
+endif

packages/numlib/Makefile.fpc

@@ -1,17 +0,0 @@
-#
-#   Makefile.fpc for NumLib
-#
-
-[package]
-name=numlib
-version=1.0.5
-
-[target]
-units=typ omv dsl mdt det eig eigh1 eigh2 int inv iom ipf ode roo sle spe spl numlib tpnumlib
-
-[install]
-fpcpackage=y
-
-[default]
-fpcdir=../..
-

packages/numlib/det.pas

@@ -1,421 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Determinants for different kinds of matrices (different with respect
-                 to symmetry)
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-unit det;
-
-interface
-{$I DIRECT.INC}
-
-uses typ;
-
-{Generic determinant}
-procedure detgen(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
-
-{determinant symmetrical matrix}
-procedure detgsy(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
-
-{determinant of a symmetrical positive definitive matrix}
-procedure detgpd(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
-
-{determinant of a generic bandmatrix}
-procedure detgba(n, l, r: ArbInt; var a, f: ArbFloat; var k, term:ArbInt);
-
-{determinant of a symmetrical positive definitive bandmatrix}
-procedure detgpb(n, l: ArbInt; var a, f: ArbFloat; var k, term:ArbInt);
-
-{determinant of a tridiagonal matrix}
-procedure detgtr(n: ArbInt; var l, d, u, f: ArbFloat; var k, term:ArbInt);
-
-{ moved to the TYP unit because of a bug in FPC 1.0.x FK
-var og          : ArbFloat absolute ogx;
-    bg          : ArbFloat absolute bgx;
-    MaxExp      : ArbInt   absolute maxexpx;
-}
-
-implementation
-
-uses mdt;
-
-procedure detgen(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
-
-var
-    kk, ind, ind1, ns, i        : ArbInt;
-    u, ca                       : ArbFloat;
-    pa, acopy                   : ^arfloat1;
-    p                           : ^arint1;
-begin
-  if (n<1) or (rwidth<1) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pa:=@a;
-  ns:=n*sizeof(ArbFloat);
-  getmem(p, n*sizeof(ArbInt));
-  getmem(acopy, n*ns);
-  ind:=1; ind1:=1;
-  for i:=1 to n do
-    begin
-      move(pa^[ind1], acopy^[ind], ns);
-      ind1:=ind1+rwidth; ind:=ind+n
-    end; {i}
-  mdtgen(n, n, acopy^[1], p^[1], ca, term);
-  if term=1 then
-    begin
-      f:=1; k:=0; kk:=1; ind:=1;
-      while (kk<=n) and (f<>0) do
-        begin
-          u:=acopy^[ind];
-          while (u<>0) and (abs(u)<og) do
-            begin
-              u:=u/og; k:=k-maxexp
-            end; {underflow control}
-          while abs(u)>bg do
-            begin
-              u:=u/bg; k:=k+maxexp
-            end; {overflow control}
-          f:=f*u;
-          if p^[kk]<>kk then f:=-f;
-          while (f<>0) and (abs(f)<og) do
-            begin
-              f:=f/og; k:=k-maxexp
-            end; {underflow control}
-          while abs(f)>bg do
-            begin
-              f:=f/bg; k:=k+maxexp
-            end; {overflow control}
-          kk:=kk+1; ind:=ind+n+1
-        end; {kk}
-    end {term=1}
-  else {term=4}
-    begin
-      f:=0; k:=0; term:=1
-    end;
-  freemem(p, n*sizeof(ArbInt));
-  freemem(acopy, n*ns)
-end; {detgen}
-
-procedure detgsy(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
-
-var i, kk, ind, ind1, s : ArbInt;
-    u, ca               : ArbFloat;
-    pa, acopy           : ^arfloat1;
-    p                   : ^arint1;
-    q                   : ^arbool1;
-begin
-  if (n<1) or (rwidth<1) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pa:=@a;
-  getmem(p, n*sizeof(ArbInt));
-  getmem(q, n*sizeof(boolean));
-  s:=sizeof(ArbFloat);
-  getmem(acopy, n*n*s);
-  ind:=1; ind1:=1;
-  for i:=1 to n do
-    begin
-      move(pa^[ind1], acopy^[ind], i*s);
-      ind1:=ind1+rwidth; ind:=ind+n
-    end; {i}
-  mdtgsy(n, n, acopy^[1], p^[1], q^[1], ca, term);
-  if term=1 then
-    begin
-      f:=1; k:=0; kk:=1; ind:=1;
-      while (kk<=n) and (f<>0) do
-        begin
-          u:=acopy^[ind];
-          while (u<>0) and (abs(u)<og) do
-            begin
-              u:=u/og; k:=k-maxexp
-            end; {underflow control}
-          while abs(u)>bg do
-            begin
-              u:=u/bg; k:=k+maxexp
-            end; {overflow control}
-          f:=f*u;
-          if q^[kk] then f:=-f;
-          while (f<>0) and (abs(f)<og) do
-            begin
-              f:=f/og; k:=k-maxexp
-            end; {underflow control}
-          while abs(f)>bg do
-            begin
-              f:=f/bg; k:=k+maxexp
-            end; {overflow control}
-          kk:=kk+1; ind:=ind+n+1
-        end; {kk}
-    end {term=1}
-  else {term=4}
-    begin
-      term:=1; f:=0; k:=0
-    end;
-  freemem(p, n*sizeof(ArbInt));
-  freemem(q, n*sizeof(boolean));
-  freemem(acopy, n*n*s)
-end; {detgsy}
-
-procedure detgpd(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
-
-var
-   i, kk, ind, ind1, s : ArbInt;
-   u, ca               : ArbFloat;
-   pa, acopy           : ^arfloat1;
-begin
-  if (n<1) or (rwidth<1) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pa:=@a;
-  s:=sizeof(ArbFloat);
-  getmem(acopy, n*n*s);
-  ind:=1; ind1:=1;
-  for i:=1 to n do
-    begin
-      move(pa^[ind1], acopy^[ind], i*s);
-      ind1:=ind1+rwidth; ind:=ind+n
-    end; {i}
-  mdtgpd(n, n, acopy^[1], ca, term);
-  if term=1 then
-    begin
-      f:=1; k:=0; kk:=1; ind:=1;
-      while kk<=n do
-        begin
-          u:=sqr(acopy^[ind]);
-          while u < og do
-            begin
-              u:=u/og; k:=k-maxexp
-            end; {underflow control}
-          while u > bg do
-            begin
-              u:=u/bg; k:=k+maxexp
-            end; {overflow control}
-          f:=f*u;
-          while f < og do
-            begin
-              f:=f/og; k:=k-maxexp
-            end; {underflow control}
-          while f > bg do
-            begin
-              f:=f/bg; k:=k+maxexp
-            end; {overflow control}
-          kk:=kk+1; ind:=ind+n+1
-        end; {kk}
-    end; {term=1}
-  freemem(acopy, n*n*s)
-end; {detgpd}
-
-procedure detgba(n, l, r: ArbInt; var a, f: ArbFloat;
-                 var k, term:ArbInt);
-var
-    rwidth, s, ns, kk, ii, i, j, jj, ll : ArbInt;
-    u, ca                               : ArbFloat;
-    pa, l1, acopy                       : ^arfloat1;
-    p                                   : ^arint1;
-begin
-  if (n<1) or (l<0) or (r<0) or (l>n-1) or (r>n-1) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pa:=@a;
-  s:=sizeof(ArbFloat); ns:=n*s;
-  ll:=l+r+1;
-  getmem(acopy, ll*ns);
-  getmem(l1, l*ns);
-  getmem(p, n*sizeof(ArbInt));
-  jj:=1; ii:=1;
-  for i:=1 to n do
-    begin
-      if i <= l+1 then
-        begin
-          if i <= (n-r) then rwidth:=r+i else rwidth:=n
-        end else
-          if i <= (n-r) then rwidth:=ll else rwidth:=n-i+l+1;
-      if i > l then kk:=ii else kk:=ii+l-i+1;
-      move(pa^[jj], acopy^[kk], rwidth*s);
-      jj:=jj+rwidth; ii:=ii+ll;
-    end; {i}
-  mdtgba(n, l, r, ll, acopy^[1], l, l1^[1], p^[1], ca, term);
-  if term=1 then
-    begin
-      f:=1; k:=0; kk:=1; ii:=1;
-      while (kk<=n) and (f<>0) do
-        begin
-          u:=acopy^[ii];
-          while (u<>0) and (abs(u)<og) do
-            begin
-              u:=u/og; k:=k-maxexp
-            end; {underflow control}
-          while abs(u)>bg do
-            begin
-              u:=u/bg; k:=k+maxexp
-            end; {overflow control}
-          f:=f*u;
-          if p^[kk]<>kk then f:=-f;
-          while (f<>0) and (abs(f)<og) do
-            begin
-              f:=f/og; k:=k-maxexp
-            end; {underflow control}
-          while abs(f)>bg do
-            begin
-              f:=f/bg; k:=k+maxexp
-            end; {overflow control}
-          kk:=kk+1; ii:=ii+ll
-        end; {kk}
-    end {term=1}
-  else {term=4}
-    begin
-      term:=1; f:=0; k:=0
-    end;
-  freemem(acopy, ll*ns);
-  freemem(l1, l*ns);
-  freemem(p, n*sizeof(ArbInt))
-end; {detgba}
-
-procedure detgpb(n, l: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
-
-var
-  rwidth, kk, ii, ns, ll, jj, i, s  : ArbInt;
-          u, ca                     : ArbFloat;
-          pa, acopy                 : ^arfloat1;
-begin
-  if (n<1) or (l<0) or (l>n-1) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pa:=@a;
-  ll:=l+1;
-  s:=sizeof(ArbFloat); ns:=s*n;
-  getmem(acopy, ll*ns);
-  jj:=1; ii:=1;
-  for i:=1 to n do
-    begin
-      if i>l then rwidth:=ll else rwidth:=i;
-      move(pa^[jj], acopy^[ii+ll-rwidth], rwidth*s);
-      jj:=jj+rwidth; ii:=ii+ll
-    end; {i}
-  mdtgpb(n, l, ll, acopy^[1], ca, term);
-  if term=1 then
-    begin
-      f:=1; k:=0; kk:=1; ii:=ll;
-      while (kk<=n) do
-        begin
-          u:=sqr(acopy^[ii]);
-          while u < og do
-            begin
-              u:=u/og; k:=k-maxexp
-            end; {underflow control}
-          while u > bg do
-            begin
-              u:=u/bg; k:=k+maxexp
-            end; {overflow control}
-          f:=f*u;
-          while f < og do
-            begin
-              f:=f/og; k:=k-maxexp
-            end; {underflow control}
-          while f > bg do
-            begin
-              f:=f/bg; k:=k+maxexp
-            end; {overflow control}
-          kk:=kk+1; ii:=ii+ll
-        end; {kk}
-    end; {term=1}
-  freemem(acopy, ll*ns);
-end; {detgpb}
-
-procedure detgtr(n: ArbInt; var l, d, u, f: ArbFloat; var k, term:ArbInt);
-
-var
-          ns, kk              : ArbInt;
-          uu, ca              : ArbFloat;
-  pl, pd, pu, l1, d1, u1, u2  : ^arfloat1;
-  p                           : ^arbool1;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pl:=@l; pd:=@d; pu:=@u;
-  ns:=n*sizeof(ArbFloat);
-  getmem(l1, ns);
-  getmem(d1, ns);
-  getmem(u1, ns);
-  getmem(u2, ns);
-  getmem(p, n*sizeof(boolean));
-  mdtgtr(n, pl^[1], pd^[1], pu^[1], l1^[1], d1^[1], u1^[1], u2^[1],
-         p^[1], ca, term);
-  if term=1 then
-    begin
-      f:=1; k:=0; kk:=1;
-      while (kk<=n) and (f<>0) do
-        begin
-          if p^[kk] then f:=-f;
-          uu:=d1^[kk];
-          while (uu<>0) and (abs(uu)<og) do
-            begin
-              uu:=uu/og; k:=k-maxexp
-            end; {underflow control}
-          while abs(uu)>bg do
-            begin
-              uu:=uu/bg; k:=k+maxexp
-            end; {overflow control}
-          f:=f*uu;
-          while (f<>0) and (abs(f)<og) do
-            begin
-              f:=f/og; k:=k-maxexp
-            end; {underflow control}
-          while abs(f)>bg do
-            begin
-              f:=f/bg; k:=k+maxexp
-            end; {overflow control}
-          kk:=kk+1
-        end; {kk}
-    end {term=1}
-  else {term=4}
-    begin
-      term:=1; f:=0; k:=0
-    end;
-  freemem(l1, ns);
-  freemem(d1, ns);
-  freemem(u1, ns);
-  freemem(u2, ns);
-  freemem(p, n*sizeof(boolean));
-end; {detgtr}
-
-end.
-{
-  $Log$
-  Revision 1.2.2.1  2002-01-16 14:57:43  florian
-  no message
-
-  Revision 1.2  2002/01/16 14:47:16  florian
-    + Makefile.fpc added
-    * several small changes to get things running with FPC 1.0.x
-
-  Revision 1.1  2000/07/13 06:34:14  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:41  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:57  marco
-   * initial version
-}

packages/numlib/direct.inc

@@ -1,2 +0,0 @@
-
-

packages/numlib/dsl.pas

@@ -1,544 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Unknown unit. There doesn't exist any documentation for it, it isn't
-    commented, and I don't recognize the algortism directly.
-    I added some comments, since suffixes of the procedures seem to indicate
-    some features of the matrixtype (from unit SLE)
-    So probably Some pivot matrix?
-
-    This code was probably internal in older libs, and only exported
-    in later versions.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-Unit dsl;
-
-interface
-{$I DIRECT.INC}
-
-
-uses typ;
-
-{Gen=generic, matrix without special or unknown ordering}
-Procedure dslgen(n, rwidth: ArbInt; Var alu: ArbFloat; Var p: ArbInt;
-                 Var b, x: ArbFloat; Var term: ArbInt);
-
-{"tridiagonal matrix"}
-Procedure dslgtr(n: ArbInt; Var l1, d1, u1, u2: ArbFloat;
-                 Var p: boolean; Var b, x: ArbFloat; Var term: ArbInt);
-
-{Symmetrical matrix}
-Procedure dslgsy(n, rwidth: ArbInt; Var alt: ArbFloat; Var p: ArbInt;
-                 Var q: boolean; Var b, x: ArbFloat; Var term: ArbInt);
-
-{Symmetrical positive definitive matrix}
-Procedure dslgpd(n, rwidth: ArbInt; Var al, b, x: ArbFloat;
-                 Var term: ArbInt);
-
-{Generic "band" matrix}
-Procedure dslgba(n, lb, rb, rwa: ArbInt; Var au: ArbFloat; rwl: ArbInt;
-                 Var l: ArbFloat; Var p: ArbInt; Var b, x: ArbFloat;
-                 Var term: ArbInt);
-
-{Positive definite bandmatrix}
-Procedure dslgpb(n, lb, rwidth: ArbInt; Var al, b, x: ArbFloat;
-                 Var term: ArbInt);
-
-{Special tridiagonal matrix}
-Procedure dsldtr(n:ArbInt; Var l, d, u, b, x: ArbFloat; Var term: ArbInt);
-
-implementation
-
-Procedure dslgen(n, rwidth: ArbInt; Var alu: ArbFloat; Var p: ArbInt;
-                 Var b, x: ArbFloat; Var term: ArbInt);
-
-Var 
-                          success : boolean;
-    indk, j, k, indexpivot, kmin1 : ArbInt;
-                      h, pivot, s : ArbFloat;
-                               pp : ^arint1;
-                     palu, pb, px : ^arfloat1;
-
-Begin
-  If (n<1) Or (rwidth<1) Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  pp := @p;
- palu := @alu;
- pb := @b;
- px := @x;
-  move(pb^, px^, n*sizeof(ArbFloat));
-  For k:=1 To n Do
-    Begin
-      indexpivot := pp^[k];
-      If indexpivot  <> k Then
-        Begin
-          h := px^[k];
-         px^[k] := px^[indexpivot];
-          px^[indexpivot] := h
-        End {indexpivot <> k}
-    End; {k}
-  For k:=2 To n Do
-    Begin
-      s := px^[k];
-     kmin1 := k-1;
-      For j:=1 To kmin1 Do
-        s := s-palu^[(k-1)*rwidth+j]*px^[j];
-      px^[k] := s
-    End; {k}
-  success := true;
- k := n+1;
-  while (k>1) and success Do
-    Begin
-      k := k-1;
-     indk := (k-1)*rwidth;
-      pivot := palu^[indk+k];
-      If pivot=0 Then
-        success := false
-      Else
-        Begin
-          s := px^[k];
-          For j:=k+1 To n Do
-            s := s-palu^[indk+j]*px^[j];
-          px^[k] := s/pivot
-        End {pivot <> 0}
-    End; {k}
-  If success Then
-    term := 1
-  Else
-    term := 2
-End; {dslgen}
-
-Procedure dslgtr(n: ArbInt; Var l1, d1, u1, u2: ArbFloat;
-                 Var p: boolean; Var b, x: ArbFloat; Var term: ArbInt);
-
-Var 
-                    i, j, nmin1 : ArbInt;
-                          h, di : ArbFloat;
-                        success : boolean;
-          pd1, pu1, pu2, pb, px : ^arfloat1;
-                            pl1 : ^arfloat2;
-                             pp : ^arbool1;
-Begin
-  If n<1 Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  pl1 := @l1;  pd1 := @d1;  pu1 := @u1; pu2 := @u2; pb := @b;  px := @x;
- pp := @p;
-  move(pb^, px^, n*sizeof(ArbFloat));
-  success := true;
- i := 0;
-  while (i<>n) and success Do
-    Begin
-      i := i+1;
-     success := pd1^[i]<>0
-    End; {i}
-  If success Then
-    Begin
-      nmin1 := n-1;
-     j := 1;
-      while j <> n Do
-        Begin
-          i := j;
-         j := j+1;
-          If pp^[i] Then
-            Begin
-              h := px^[i];
-             px^[i] := px^[j];
-             px^[j] := h-pl1^[j]*px^[i]
-            End {pp^[i]}
-          Else
-            px^[j] := px^[j]-pl1^[j]*px^[i]
-        End;  {j}
-      di := pd1^[n];
-      px^[n] := px^[n]/di;
-      If n > 1 Then
-        Begin
-          di := pd1^[nmin1];
-          px^[nmin1] := (px^[nmin1]-pu1^[nmin1]*px^[n])/di
-        End; {n > 1}
-      For i:=n-2 Downto 1 Do
-        Begin
-          di := pd1^[i];
-          px^[i] := (px^[i]-pu1^[i]*px^[i+1]-pu2^[i]*px^[i+2])/di
-        End {i}
-    End; {success}
-  If success Then
-    term := 1
-  Else
-    term := 2
-End; {dslgtr}
-
-Procedure dslgsy(n, rwidth: ArbInt; Var alt: ArbFloat; Var p: ArbInt;
-                 Var q: boolean; Var b, x: ArbFloat; Var term: ArbInt);
-
-Var 
-    i, indexpivot, imin1, j, jmin1, iplus1, imin2, ns, ii  : ArbInt;
-                                          success, regular : boolean;
-                                                 h, ct, di : ArbFloat;
-                               palt, pb, px, y, l, d, u, v : ^arfloat1;
-                                                        pp : ^arint1;
-                                                        pq : ^arbool1;
-
-Begin
-  If (n<1) Or (rwidth<1) Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  palt := @alt;
- pp := @p;
- pq := @q;
- pb := @b;
- px := @x;
-  ns := n*sizeof(ArbFloat);
-  getmem(l, ns);
-  getmem(d, ns);
-  getmem(u, ns);
-  getmem(v, ns);
-  getmem(y, ns);
-  move(pb^, y^, ns);
-  success := true;
- i := 0;
- ii := 1;
-  while (i<>n) and success Do
-    Begin
-      i := i+1;
-     success := palt^[ii]<>0;
-     ii := ii+rwidth+1
-    End; {i}
-  If success Then
-    Begin
-      For i:=1 To n Do
-        Begin
-          indexpivot := pp^[i];
-          If indexpivot <> i Then
-            Begin
-              h := y^[i];
-             y^[i] := y^[indexpivot];
-              y^[indexpivot] := h
-            End {indexpivot <> i}
-        End; {i}
-      i := 0;
-      while i<n Do
-        Begin
-          imin1 := i;
-         i := i+1;
-         j := 1;
-         h := y^[i];
-          while j<imin1 Do
-            Begin
-              jmin1 := j;
-             j := j+1;
-              h := h-palt^[(i-1)*rwidth+jmin1]*y^[j]
-            End; {j}
-          y^[i] := h
-        End; {i}
-      d^[1] := palt^[1];
-     di := d^[1];
-      If n>1 Then
-        Begin
-          l^[1] := palt^[rwidth+1];
-         d^[2] := palt^[rwidth+2];
-          di := d^[2];
-          u^[1] := palt^[2]
-        End; {n>1}
-      imin1 := 1;
-     i := 2;
-      while i<n Do
-        Begin
-          imin2 := imin1;
-         imin1 := i;
-         i := i+1;
-          ii := (i-1)*rwidth;
-          l^[imin1] := palt^[ii+imin1];
-         d^[i] := palt^[ii+i];
-         di := d^[i];
-          u^[imin1] := palt^[ii-rwidth+i];
-         v^[imin2] := palt^[ii-2*rwidth+i]
-        End; {i}
-      dslgtr(n, l^[1], d^[1], u^[1], v^[1], pq^[1], y^[1], px^[1], term);
-      i := n+1;
-     imin1 := n;
-      while i>2 Do
-        Begin
-          iplus1 := i;
-         i := imin1;
-         imin1 := imin1-1;
-         h := px^[i];
-          For j:=iplus1 To n Do
-            h := h-palt^[(j-1)*rwidth+imin1]*px^[j];
-          px^[i] := h
-        End; {i}
-      For i:=n Downto 1 Do
-        Begin
-          indexpivot := pp^[i];
-          If indexpivot <> i Then
-            Begin
-              h := px^[i];
-             px^[i] := px^[indexpivot];
-              px^[indexpivot] := h
-            End {indexpivot <> i}
-        End {i}
-   End; {success}
-  If success Then
-    term := 1
-  Else
-    term := 2;
-  freemem(l, ns);
-  freemem(d, ns);
-  freemem(u, ns);
-  freemem(v, ns);
-  freemem(y, ns)
-End; {dslgsy}
-
-Procedure dslgpd(n, rwidth: ArbInt; Var al, b, x: ArbFloat;
-                 Var term: ArbInt);
-
-Var 
-       ii, imin1, i, j : ArbInt;
-                h, lii : ArbFloat;
-               success : boolean;
-           pal, pb, px : ^arfloat1;
-Begin
-  If (n<1) Or (rwidth<1) Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  pal := @al;
- pb := @b;
- px := @x;
-  move(pb^, px^, n*sizeof(ArbFloat));
-  success := true;
- i := 0;
- ii := 1;
-  while (i<>n) and success Do
-    Begin
-      i := i+1;
-     success := pal^[ii]<>0;
-     ii := ii+rwidth+1
-    End; {i}
-  If success Then
-    Begin
-      For i:=1 To n Do
-        Begin
-          ii := (i-1)*rwidth;
-          h := px^[i];
-         imin1 := i-1;
-          For j:=1 To imin1 Do
-            h := h-pal^[ii+j]*px^[j];
-          lii := pal^[ii+i];
-          px^[i] := h/lii
-        End; {i}
-      For i:=n Downto 1 Do
-        Begin
-          h := px^[i];
-          For j:=i+1 To n Do
-            h := h-pal^[(j-1)*rwidth+i]*px^[j];
-          px^[i] := h/pal^[(i-1)*rwidth+i]
-        End {i}
-    End; {success}
-  If success Then
-    term := 1
-  Else
-    term := 2
-End;  {dslgpd}
-
-Procedure dslgba(n, lb, rb, rwa: ArbInt; Var au: ArbFloat; rwl: ArbInt;
-                 Var l: ArbFloat; Var p: ArbInt; Var b, x: ArbFloat;
-                 Var term: ArbInt);
-
-Var 
-   i, j, k, ipivot, ubi, ubj : ArbInt;
-   h, pivot                  : ArbFloat;
-   pau, pl, px, pb           : ^arfloat1;
-   pp                        : ^arint1;
-
-Begin
-  If (n<1) Or (lb<0) Or (rb<0) Or (lb>n-1)
-        Or (rb>n-1) Or (rwa<1) Or (rwl<0) Then
-    Begin
-      term := 3;
-     exit
-    End; {term=3}
-  pau := @au;
- pl := @l;
- pb := @b;
- px := @x;
- pp := @p;
-  move(pb^, px^, n*sizeof(ArbFloat));
-  ubi := lb;
-  For k:=1 To n Do
-    Begin
-      ipivot := pp^[k];
-      If ipivot <> k Then
-        Begin
-          h := px^[k];
-         px^[k] := px^[ipivot];
-          px^[ipivot] := h
-        End; {ipivot <> k}
-      If ubi<n Then
-        ubi := ubi+1;
-      For i:=k+1 To ubi Do
-        px^[i] := px^[i]-px^[k]*pl^[(k-1)*rwl+i-k]
-    End; {k}
-  ubj := 0;
- i := n;
- term := 1;
-  while (i >= 1) and (term=1) Do
-    Begin
-      If ubj<rb+lb+1 Then
-        ubj := ubj+1;
-      h := px^[i];
-      For j:=2 To ubj Do
-        h := h-pau^[(i-1)*rwa+j]*px^[i+j-1];
-      pivot := pau^[(i-1)*rwa+1];
-      If pivot=0 Then
-        term := 2
-      Else
-        px^[i] := h/pivot;
-      i := i-1
-    End {i}
-End; {dslgba}
-
-Procedure dslgpb(n, lb, rwidth: ArbInt; Var al, b, x: ArbFloat;
-                 Var term: ArbInt);
-
-Var 
-   ll, ii, llmin1, p, i, q, k : ArbInt;
-            h, hh, alim       : ArbFloat;
-                  pal, pb, px : ^arfloat1;
-Begin
-  If (lb<0) Or (lb>n-1) Or (n<1) Or (rwidth<1) Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  pal := @al;
- pb := @b;
- px := @x;
-  move(pb^, px^, n*sizeof(ArbFloat));
-  ll := lb+1;
-  llmin1 := ll-1;
- p := ll+1;
- term := 1;
- i := 1;
-  while (i <= n) and (term=1) Do
-    Begin
-      ii := (i-1)*rwidth;
-      If p>1 Then
-        p := p-1;
-      h := px^[i];
-     q := i;
-      For k:=llmin1 Downto p Do
-        Begin
-          q := q-1;
-         h := h-pal^[ii+k]*px^[q]
-        End; {k}
-      alim := pal^[ii+ll];
-      If alim=0 Then
-        term := 2
-      Else
-        px^[i] := h/alim;
-      i := i+1
-    End; {i}
-  If term=1 Then
-    Begin
-      p := ll+1;
-      For i:=n Downto 1 Do
-        Begin
-          If p>1 Then
-            p := p-1;
-          q := i;
-         h := px^[i];
-          For k:=llmin1 Downto p Do
-            Begin
-              q := q+1;
-             h := h-pal^[(q-1)*rwidth+k]*px^[q]
-            End; {k}
-          px^[i] := h/pal^[(i-1)*rwidth+ll]
-        End {i}
-    End {term=1}
-End; {dslgpb}
-
-Procedure dsldtr(n:ArbInt; Var l, d, u, b, x: ArbFloat; Var term: ArbInt);
-
-Var 
-                   i, j : ArbInt;
-                     di : ArbFloat;
-         pd, pu, pb, px : ^arfloat1;
-                     pl : ^arfloat2;
-Begin
-  If n<1 Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  pl := @l;
- pd := @d;
- pu := @u;
- pb := @b;
- px := @x;
-  move(pb^, px^, n*sizeof(ArbFloat));
-  j := 1;
-  while j <> n Do
-    Begin
-      i := j;
-     j := j+1;
-     px^[j] := px^[j]-pl^[j]*px^[i]
-    End;
-  di := pd^[n];
-  If di=0 Then
-    term := 2
-  Else
-    term := 1;
-  If term=1 Then
-    px^[n] := px^[n]/di;
-  i := n-1;
-  while (i >= 1) and (term=1) Do
-    Begin
-      di := pd^[i];
-      If di=0 Then
-        term := 2
-      Else
-        px^[i] := (px^[i]-pu^[i]*px^[i+1])/di;
-      i := i-1
-    End; {i}
-End; {dsldtr}
-
-End.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:43  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:14  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:41  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/eig.pas

@@ -1,826 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-unit eig;
-{$I DIRECT.INC}
-
-interface
-
-uses typ;
-
-const versie = 'augustus 1993';
-
-procedure eiggs1(var a: ArbFloat; n, rwidth: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-
-procedure eiggs2(var a: ArbFloat; n, rwidth, k1, k2: ArbInt;
-                 var lam: ArbFloat; var term: ArbInt);
-
-procedure eiggs3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: ArbFloat;
-                 rwidthx: ArbInt; var term: ArbInt);
-
-procedure eiggs4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var lam, x: ArbFloat;
-                 rwidthx: ArbInt; var m2, term: ArbInt);
-
-procedure eigts1(var d, cd: ArbFloat; n: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-
-procedure eigts2(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-
-procedure eigts3(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;
-                 rwidth: ArbInt; var term: ArbInt);
-
-procedure eigts4(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam, x: ArbFloat;
-                 rwidth: ArbInt; var m2, term: ArbInt);
-
-procedure eigbs1(var a: ArbFloat; n, l: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-
-procedure eigbs2(var a: ArbFloat; n, l, k1, k2: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-
-procedure eigbs3(var a: ArbFloat; n, l: ArbInt; var lam, x: ArbFloat;
-                 rwidthx: ArbInt; var term: ArbInt);
-
-procedure eigbs4(var a: ArbFloat; n, l, k1, k2: ArbInt;
-                 var lam, x: ArbFloat;  rwidthx: ArbInt;
-                 var m2, term: ArbInt);
-
-procedure eigge1(var a: ArbFloat; n, rwidth: ArbInt; var lam: complex;
-                 var term: ArbInt);
-
-procedure eigge3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: complex;
-                 rwidthx: ArbInt; var term: ArbInt);
-
-procedure eiggg1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt);
-
-procedure eiggg2(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt);
-
-procedure eiggg3(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;
-                 var term: ArbInt);
-
-procedure eiggg4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;
-                 var m2, term: ArbInt);
-
-procedure eigsv1(var a: ArbFloat; m, n, rwidth: ArbInt; var sig: ArbFloat;
-                 var term: ArbInt);
-
-procedure eigsv3(var a: ArbFloat; m, n, rwidtha: ArbInt; var sig, u: ArbFloat;
-                 rwidthu: ArbInt; var v: ArbFloat; rwidthv: ArbInt;
-                 var term: ArbInt);
-
-implementation
-
-uses eigh1, eigh2;
-
-procedure eiggs1(var a: ArbFloat; n, rwidth: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-var            i, sr, nsr : ArbInt;
-    d, cd, dh, cdh, u, pa : ^arfloat1;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pa:=@a;
-  sr:=sizeof(ArbFloat); nsr:=n*sr;
-  getmem(d, nsr); getmem(cd, nsr); getmem(dh, nsr); getmem(cdh, nsr);
-  getmem(u, n*nsr);
-  for i:=1 to n do move(pa^[(i-1)*rwidth+1], u^[(i-1)*n+1], i*sr);
-  tred1(u^[1], n, n, d^[1], cd^[1], term);
-  move(d^[1], dh^[1], nsr); move(cd^[1], cdh^[1], nsr);
-  tql1(d^[1], cd^[1], n, lam, term);
-  if term=2 then bisect(dh^[1], cdh^[1], n, 1, n, 0, lam, term);
-  freemem(d, nsr); freemem(cd, nsr); freemem(dh, nsr); freemem(cdh, nsr);
-  freemem(u, n*nsr);
-end; {eiggs1}
-
-procedure eiggs2(var a: ArbFloat; n, rwidth, k1, k2: ArbInt;
-                 var lam: ArbFloat; var term: ArbInt);
-var          i, sr, nsr : ArbInt;
-           d, cd, u, pa : ^arfloat1;
-begin
-  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pa:=@a;
-  sr:=sizeof(ArbFloat); nsr:=n*sr;
-  getmem(d, nsr); getmem(cd, nsr); getmem(u, n*nsr);
-  for i:=1 to n do move(pa^[(i-1)*rwidth+1], u^[(i-1)*n+1], i*sr);
-  tred1(u^[1], n, n, d^[1], cd^[1], term);
-  bisect(d^[1], cd^[1], n, k1, k2, 0, lam, term);
-  freemem(d, nsr); freemem(cd, nsr); freemem(u, n*nsr);
-end; {eiggs2}
-
-procedure eiggs3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: ArbFloat;
-                 rwidthx: ArbInt; var term: ArbInt);
-var   nsr : ArbInt;
-    d, cd : ^arfloat1;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end;
-  nsr:=n*sizeof(ArbFloat);
-  getmem(d, nsr); getmem(cd, nsr);
-  tred2(a, n, rwidtha, d^[1], cd^[1], x, rwidthx, term);
-  tql2(d^[1], cd^[1], n, lam, x, rwidthx, term);
-  freemem(d, nsr); freemem(cd, nsr)
-end;  {eiggs3}
-
-procedure eiggs4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var lam, x: ArbFloat;
-                 rwidthx: ArbInt; var m2, term: ArbInt);
-var      i, sr, nsr : ArbInt;
-       pa, d, cd, u : ^arfloat1;
-begin
-  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pa:=@a;
-  sr:=sizeof(ArbFloat); nsr:=n*sr;
-  getmem(d, nsr); getmem(cd, nsr); getmem(u, n*nsr);
-  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], i*sr);
-  tred1(u^[1], n, n, d^[1], cd^[1], term);
-  trsturm1(d^[1], cd^[1], n, k1, k2, lam, x, rwidthx, m2, term);
-  trbak1(u^[1], n, n, cd^[1], k1, k2, x, rwidthx);
-  freemem(d, nsr); freemem(cd, nsr); freemem(u, n*nsr) { toegevoegd 3 apr 92 }
-end; {eiggs4}
-
-procedure eigts1(var d, cd: ArbFloat; n: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-var               sr, nsr : ArbInt;
-         pd, pcd, dh, cdh : ^arfloat1;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  sr:=sizeof(ArbFloat); nsr:=n*sr;
-  pd:=@d; pcd:=@cd; getmem(dh, nsr); getmem(cdh, nsr);
-  move(pd^[1], dh^[1], nsr); move(pcd^[1], cdh^[2], (n-1)*sr);
-  tql1(dh^[1], cdh^[1], n, lam, term);
-  if term=2 then
-    begin
-      move(pd^[1], dh^[1], nsr); move(pcd^[1], cdh^[2], (n-1)*sr);
-      bisect(dh^[1], cdh^[1], n, 1, n, 0, lam, term)
-    end;
-  freemem(dh, nsr); freemem(cdh, nsr);
-end; {eigts1}
-
-procedure eigts2(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-var               sr, nsr : ArbInt;
-                 pcd, cdh : ^arfloat1;
-begin
-  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pcd:=@cd;
-  term:=1; sr:=sizeof(ArbFloat); nsr:=n*sr; getmem(cdh, nsr);
-  move(pcd^[1], cdh^[2], (n-1)*sr);
-  bisect(d, cdh^[1], n, k1, k2, 0, lam, term);
-  freemem(cdh, nsr)
-end; {eigts2}
-
-procedure eigts3(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;
-                 rwidth: ArbInt; var term: ArbInt);
-var             i, sr, nsr : ArbInt;
-              px, pcd, cdh : ^arfloat1;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end;
-  px:=@x; pcd:=@cd;
-  sr:=sizeof(ArbFloat); nsr:=n*sr;
-  getmem(cdh, nsr);
-  move(pcd^[1], cdh^[2], (n-1)*sr);
-  for i:=1 to n do fillchar(px^[(i-1)*rwidth+1], nsr, 0);
-  for i:=1 to n do px^[(i-1)*rwidth+i]:=1;
-  tql2(d, cdh^[1], n, lam, px^[1], rwidth, term);
-  freemem(cdh, nsr);
-end;  {eigts3}
-
-procedure eigts4(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam, x: ArbFloat;
-                 rwidth: ArbInt; var m2, term: ArbInt);
-var                    sr : ArbInt;
-                 pcd, cdh : ^arfloat1;
-begin
-  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  term:=1;
-  pcd:=@cd; sr:=sizeof(ArbFloat);
-  getmem(cdh, n*sr);
-  move(pcd^[1], cdh^[2], (n-1)*sr);
-  trsturm1(d, cdh^[1], n, k1, k2, lam, x, rwidth, m2, term);
-  freemem(cdh, n*sr)
-end; {eigts4}
-
-procedure eigbs1(var a: ArbFloat; n, l: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-var             u, d, cd : ^arfloat1;
-      uwidth, i, sr, nsr : ArbInt;
-begin
-  if (n<1) or (l<0) or (l>n-1) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  sr:=sizeof(ArbFloat); nsr:=n*sr; uwidth:=l+1;
-  getmem(u, uwidth*nsr); getmem(d, nsr); getmem(cd, nsr);
-  transf(a, n, l, u^[1], uwidth);
-  bandrd1(u^[1], n, l, uwidth, d^[1], cd^[1]);
-  eigts1(d^[1], cd^[2], n, lam, term);
-  freemem(u, uwidth*nsr); freemem(d, nsr); freemem(cd, nsr);
-end; {eigbs1}
-
-procedure eigbs2(var a: ArbFloat; n, l, k1, k2: ArbInt; var lam: ArbFloat;
-                 var term: ArbInt);
-var                  u, d, cd : ^arfloat1;
-           i, sr, nsr, uwidth : ArbInt;
-begin
-  if (n<1) or (k1<1) or (k2<k1) or (k2>n) or (l<0) or (l>n-1) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  sr:=sizeof(ArbFloat); nsr:=n*sr; uwidth:=l+1;
-  getmem(u, uwidth*nsr); getmem(d, nsr); getmem(cd, nsr);
-  transf(a, n, l, u^[1], uwidth);
-  bandrd1(u^[1], n, l, uwidth, d^[1], cd^[1]);
-  eigts2(d^[1], cd^[2], n, k1, k2, lam, term);
-  freemem(u, uwidth*nsr); freemem(d, nsr); freemem(cd, nsr)
-end; {eigbs2}
-
-procedure eigbs3(var a: ArbFloat; n, l: ArbInt; var lam, x: ArbFloat;
-                 rwidthx: ArbInt; var term: ArbInt);
-var                  u, d, cd : ^arfloat1;
-           i, sr, nsr, uwidth : ArbInt;
-begin
-  if (n<1) or (l<0) or (l>n-1) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  sr:=sizeof(ArbFloat); nsr:=n*sr; uwidth:=l+1;
-  getmem(u, uwidth*nsr); getmem(d, nsr); getmem(cd, nsr);
-  transf(a, n, l, u^[1], uwidth);
-  bandrd2(u^[1], n, l, uwidth, d^[1], cd^[1], x, rwidthx);
-  tql2(d^[1], cd^[1], n, lam, x, rwidthx, term);
-  freemem(u, uwidth*nsr); freemem(d, nsr); freemem(cd, nsr)
-end; {eigbs3}
-
-procedure eigbs4(var a: ArbFloat; n, l, k1, k2: ArbInt;
-                 var lam, x: ArbFloat;  rwidthx: ArbInt;
-                 var m2, term: ArbInt);
-var  i, j, k, m, uwidth : ArbInt;
-     plam, px, pa, v, u : ^arfloat1;
-                s, norm : ArbFloat;
-begin
-  if (n<1) or (k1<1) or (k2<k1) or (k2>n) or (l<0) or (l>n-1) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  plam:=@lam; px:=@x; pa:=@a; getmem(v, n*sizeof(ArbFloat));
-  uwidth:=l+1; getmem(u, n*uwidth*sizeof(ArbFloat));
-  eigbs2(a, n, l, k1, k2, plam^[1], term);
-  { kijk of norm(A-lambda.I)=0 }
-  { zo ja, lever dan de eenheidsvectoren e(k1) t/m e(k2) af }
-  norm:=0; j:=1;
-  for i:=1 to n do
-  begin
-      if i<=l then m:=i else m:=l+1; s:=0;
-      for k:=j to j+m-1 do
-      if k=j+m-1 then s:=s+abs(pa^[k]-plam^[1]) else s:=s+abs(pa^[k]);
-      if s>norm then norm:=s;
-      j:=j+m
-  end;
-  if norm=0 then
-  begin
-      for i:=k1 to k2 do for j:=1 to n do
-      if j=i then px^[(j-1)*rwidthx+i-k1+1]:=1
-      else px^[(j-1)*rwidthx+i-k1+1]:=0;
-      freemem(v, n*sizeof(ArbFloat)); freemem(u, n*uwidth*sizeof(ArbFloat));
-      m2:=k2; term:=1; exit
-  end;
-  transf(a, n, l, u^[1], uwidth);
-  i:=k1; m2:=k1-1;
-  while (i <= k2) and (term=1) do
-    begin
-      bandev(u^[1], n, l, uwidth, plam^[i-k1+1], v^[1], term);
-      if term=1 then
-        begin
-          m2:=i; for j:=1 to n do px^[(j-1)*rwidthx+i-k1+1]:=v^[j]
-        end;
-      i:=i+1
-    end; {i}
-  freemem(v, n*sizeof(ArbFloat));
-  freemem(u, n*uwidth*sizeof(ArbFloat));
-end; {eigbs4}
-
-procedure eigge1(var a: ArbFloat; n, rwidth: ArbInt; var lam: complex;
-                 var term: ArbInt);
-var pa, h, dummy : ^arfloat1;
-           i, ns : ArbInt;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end;
-  ns:=n*sizeof(ArbFloat); pa:=@a;
-  getmem(dummy, ns); getmem(h, n*ns);
-  for i:=1 to n do move(pa^[(i-1)*rwidth+1], h^[(i-1)*n+1], ns);
-  orthes(h^[1], n, n, dummy^[1]);
-  hessva(h^[1], n, n, lam, term);
-  freemem(dummy, ns); freemem(h, n*ns);
-end;  {eigge1}
-
-procedure eigge3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: complex;
-                 rwidthx: ArbInt; var term: ArbInt);
-var     pa, pd, u, v: ^arfloat1;
-    m1, m2, i, j, ns: ArbInt;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end;
-  ns:=n*sizeof(ArbFloat); getmem(pd, ns); getmem(u, n*ns); getmem(v, n*ns);
-  pa:=@a; for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
-  balance(u^[1], n, n, m1, m2, pd^[1]);
-  orttrans(u^[1], n, n, v^[1], n);
-  hessvec(u^[1], n, n, lam, v^[1], n, term);
-  if term=1 then
-    begin
-      balback(pd^[1], n, m1, m2, 1, n, v^[1], n);
-      normeer(lam, n, v^[1], n);
-      transx(v^[1], n, n, lam, x, rwidthx)
-    end;
-  freemem(pd, ns); freemem(u, n*ns); freemem(v, n*ns);
-end;  {eigge3}
-
-procedure eiggg1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt);
-var u, v, pa, pb : ^arfloat1;
-        i, j, ns : ArbInt;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end;
-  pa:=@a; pb:=@b; ns:=n*sizeof(ArbFloat); getmem(u, n*ns); getmem(v, n*ns);
-  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
-  for i:=1 to n do move(pb^[(i-1)*rwidthb+1], v^[(i-1)*n+1], ns);
-  reduc1(u^[1], n, n, v^[1], n, term);
-  if term=1 then eiggs1(u^[1], n, n, lam, term);
-  freemem(u, n*ns); freemem(v, n*ns);
-end; {eiggg1}
-
-procedure eiggg2(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt);
-var u, v, pa, pb : ^arfloat1;
-        i, j, ns : ArbInt;
-begin
-  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
-    begin
-      term:=3; exit
-    end;
-  pa:=@a; pb:=@b; ns:=n*sizeof(ArbFloat); getmem(u, n*ns); getmem(v, n*ns);
-  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
-  for i:=1 to n do move(pb^[(i-1)*rwidthb+1], v^[(i-1)*n+1], ns);
-  reduc1(u^[1], n, n, v^[1], n, term);
-  if term=1 then eiggs2(u^[1], n, n, k1, k2, lam, term);
-  freemem(u, n*ns); freemem(v, n*ns)
-end; {eiggg2}
-
-procedure eiggg3(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;
-                 var term: ArbInt);
-var u, v, pa, pb : ^arfloat1;
-        i, j, ns : ArbInt;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end;
-  pa:=@a; pb:=@b;
-  ns:=n*sizeof(ArbFloat);
-  getmem(u, n*ns); getmem(v, n*ns);
-  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
-  for i:=1 to n do move(pb^[(i-1)*rwidthb+1], v^[(i-1)*n+1], ns);
-  reduc1(u^[1], n, n, v^[1], n, term);
-  if term=1 then
-    begin
-      eiggs3(u^[1], n, n, lam, x, rwidthx, term);
-      if term=1 then rebaka(v^[1], n, n, 1, n, x, rwidthx, term)
-    end;
-  freemem(u, n*ns); freemem(v, n*ns)
-end; {eiggg3}
-
-procedure eiggg4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;
-                 var m2, term: ArbInt);
-
-var u, v, pa, pb : ^arfloat1;
-     i, j, ns, t : ArbInt;
-begin
-  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
-    begin
-      term:=3; exit
-    end;
-  pa:=@a; pb:=@b; ns:=n*sizeof(ArbFloat); getmem(u, n*ns); getmem(v, n*ns);
-  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
-  for i:=1 to n do move(pb^[(i-1)*rwidthb+1], v^[(i-1)*n+1], ns);
-  reduc1(u^[1], n, n, v^[1], n, term);
-  if term=1 then
-    begin
-      eiggs4(u^[1], n, n, k1, k2, lam, x, rwidthx, m2, term);
-      if m2 < k2 then term:=4;
-      if m2 > k1-1 then
-        begin
-          rebaka(v^[1], n, n, k1, m2, x, rwidthx, t);
-          if t=2 then
-            begin
-              term:=4; m2:=k1-1
-            end
-        end
-    end;
-  freemem(u, n*ns); freemem(v, n*ns)
-end; {eiggg4}
-
-procedure eigsv1(var a: ArbFloat; m, n, rwidth: ArbInt; var sig: ArbFloat;
-                 var term: ArbInt);
-
-var                     pa, pq, u, e : ^arfloat1;
-          i, j, k, l, ns, ii, jj, kk : ArbInt;
- c, f, g, h, p, s, x, y, z, eps, tol : ArbFloat;
-                  conv, goon, cancel : boolean;
-begin
-  if (n<1) or (m<n) then
-    begin
-      term:=3; exit
-    end;
-  pa:=@a; pq:=@sig; term:=1;
-  ns:=n*sizeof(ArbFloat); getmem(e, ns); getmem(u, m*ns);
-  for i:=1 to m do move(pa^[(i-1)*rwidth+1], u^[(i-1)*n+1], ns);
-  g:=0; x:=0; tol:=midget/macheps;
-  for i:=1 to n do
-    begin
-      ii:=(i-1)*n; e^[i]:=g;
-      s:=0; for j:=i to m do s:=s+sqr(u^[(j-1)*n+i]);
-      if s<tol then g:=0 else
-        begin
-          f:=u^[ii+i]; if f<0 then g:=sqrt(s) else g:=-sqrt(s);
-          h:=f*g-s; u^[ii+i]:=f-g;
-          for j:=i+1 to n do
-            begin
-              s:=0;
-              for k:=i to m do
-                begin
-                  kk:=(k-1)*n; s:=s+u^[kk+i]*u^[kk+j]
-                end; {k}
-              f:=s/h;
-              for k:=i to m do
-                begin
-                  kk:=(k-1)*n; u^[kk+j]:=u^[kk+j]+f*u^[kk+i]
-                end {k}
-            end {j}
-        end; {s}
-      pq^[i]:=g; s:=0;
-      for j:=i+1 to n do s:=s+sqr(u^[ii+j]);
-      if s < tol then g:=0 else
-        begin
-          f:=u^[ii+i+1]; if f < 0 then g:=sqrt(s) else g:=-sqrt(s);
-          h:=f*g-s; u^[ii+i+1]:=f-g;
-          for j:=i+1 to n do e^[j]:=u^[ii+j]/h;
-          for j:=i+1 to m do
-            begin
-              s:=0; jj:=(j-1)*n;
-              for k:=i+1 to n do s:=s+u^[jj+k]*u^[ii+k];
-              for k:=i+1 to n do u^[jj+k]:=u^[jj+k]+s*e^[k]
-            end {j}
-        end; {s}
-      y:=abs(pq^[i])+abs(e^[i]); if y > x then x:=y
-    end; {i}
-  eps:=macheps*x;
-  for k:=n downto 1 do
-    begin
-      conv:=false;
-      repeat
-        l:=k; goon:=true;
-        while goon do
-          begin
-            if abs(e^[l]) <= eps then
-              begin
-                goon:=false; cancel:=false
-              end else
-            if abs(pq^[l-1]) <= eps then
-              begin
-                goon:=false; cancel:=true
-              end
-            else l:=l-1
-          end; {goon}
-        if cancel then
-          begin
-            c:=0; s:=1;
-            i:=l; goon:=true;
-            while goon do
-              begin
-                f:=s*e^[i]; e^[i]:=c*e^[i]; goon:=abs(f) > eps;
-                if goon then
-                  begin
-                    g:=pq^[i]; h:=sqrt(f*f+g*g); pq^[i]:=h;
-                    c:=g/h; s:=-f/h;
-                    i:=i+1; goon:=i <= k
-                  end {goon}
-              end {while goon}
-          end; {cancel}
-        z:=pq^[k];
-        if k=l then conv:=true else
-          begin
-            x:=pq^[l]; y:=pq^[k-1]; g:=e^[k-1]; h:=e^[k];
-            f:=((y-z)*(y+z)+(g-h)*(g+h))/(2*h*y); g:=sqrt(f*f+1);
-            if f < 0 then s:=f-g else s:=f+g;
-            f:=((x-z)*(x+z)+h*(y/s-h))/x;
-            c:=1; s:=1;
-            for i:=l+1 to k do
-              begin
-                g:=e^[i]; y:=pq^[i]; h:=s*g; g:=c*g;
-                z:=sqrt(f*f+h*h); e^[i-1]:=z; c:=f/z; s:=h/z;
-                f:=x*c+g*s; g:=-x*s+g*c; h:=y*s; y:=y*c;
-                z:=sqrt(f*f+h*h); pq^[i-1]:=z; c:=f/z; s:=h/z;
-                f:=c*g+s*y; x:=-s*g+c*y
-              end; {i}
-            e^[l]:=0; e^[k]:=f; pq^[k]:=x
-          end {k <> l}
-      until conv;
-      if z < 0 then pq^[k]:=-z
-    end; {k}
-  for i:=1 to n do
-    begin
-      k:=i; p:=pq^[i];
-      for j:=i+1 to n do
-        if pq^[j] < p then
-          begin
-            k:=j; p:=pq^[j]
-          end;
-        if k <> i then
-          begin
-            pq^[k]:=pq^[i]; pq^[i]:=p
-          end
-    end; {i}
-  freemem(e, ns); freemem(u, m*ns)
-end; {eigsv1}
-
-procedure eigsv3(var a: ArbFloat; m, n, rwidtha: ArbInt; var sig, u: ArbFloat;
-                 rwidthu: ArbInt; var v: ArbFloat; rwidthv: ArbInt;
-                 var term: ArbInt);
-
-var                pa, pu, pq, pv, e : ^arfloat1;
-          i, j, k, l, ns, ii, jj, kk : ArbInt;
- c, f, g, h, p, s, x, y, z, eps, tol : ArbFloat;
-                  conv, goon, cancel : boolean;
-begin
-  if (n<1) or (m<n)
-  then
-    begin
-      term:=3; exit
-    end;
-  pa:=@a; pu:=@u; pq:=@sig; pv:=@v; term:=1;
-  ns:=n*sizeof(ArbFloat); getmem(e, ns);
-  for i:=1 to m do move(pa^[(i-1)*rwidtha+1], pu^[(i-1)*rwidthu+1], ns);
-  g:=0; x:=0; tol:=midget/macheps;
-  for i:=1 to n do
-    begin
-      ii:=(i-1)*rwidthu;
-      e^[i]:=g; s:=0;
-      for j:=i to m do s:=s+sqr(pu^[(j-1)*rwidthu+i]);
-      if s<tol then g:=0 else
-        begin
-          f:=pu^[ii+i]; if f<0 then g:=sqrt(s) else g:=-sqrt(s);
-          h:=f*g-s; pu^[ii+i]:=f-g;
-          for j:=i+1 to n do
-            begin
-              s:=0;
-              for k:=i to m do
-                begin
-                  kk:=(k-1)*rwidthu; s:=s+pu^[kk+i]*pu^[kk+j]
-                end; {k}
-              f:=s/h;
-              for k:=i to m do
-                begin
-                  kk:=(k-1)*rwidthu; pu^[kk+j]:=pu^[kk+j]+f*pu^[kk+i]
-                end {k}
-            end {j}
-        end; {s}
-      pq^[i]:=g; s:=0; for j:=i+1 to n do s:=s+sqr(pu^[ii+j]);
-      if s < tol then g:=0 else
-        begin
-          f:=pu^[ii+i+1];
-          if f < 0 then g:=sqrt(s) else g:=-sqrt(s);
-          h:=f*g-s; pu^[ii+i+1]:=f-g;
-          for j:=i+1 to n do e^[j]:=pu^[ii+j]/h;
-          for j:=i+1 to m do
-            begin
-              s:=0; jj:=(j-1)*rwidthu;
-              for k:=i+1 to n do s:=s+pu^[jj+k]*pu^[ii+k];
-              for k:=i+1 to n do pu^[jj+k]:=pu^[jj+k]+s*e^[k]
-            end {j}
-        end; {s}
-      y:=abs(pq^[i])+abs(e^[i]); if y > x then x:=y
-    end; {i}
-  for i:=n downto 1 do
-    begin
-      ii:=(i-1)*rwidthu;
-      if g <> 0 then
-        begin
-          h:=pu^[ii+i+1]*g;
-          for j:=i+1 to n do pv^[(j-1)*rwidthv+i]:=pu^[ii+j]/h;
-          for j:=i+1 to n do
-            begin
-              s:=0;
-              for k:=i+1 to n do s:=s+pu^[ii+k]*pv^[(k-1)*rwidthv+j];
-              for k:=i+1 to n do
-                begin
-                  kk:=(k-1)*rwidthv; pv^[kk+j]:=pv^[kk+j]+s*pv^[kk+i]
-                end {k}
-            end {j}
-        end; {g}
-      ii:=(i-1)*rwidthv;
-      for j:=i+1 to n do
-        begin
-          pv^[ii+j]:=0; pv^[(j-1)*rwidthv+i]:=0
-        end; {j}
-      pv^[ii+i]:=1; g:=e^[i]
-    end; {i}
-  for i:=n downto 1 do
-    begin
-      g:=pq^[i]; ii:=(i-1)*rwidthu;
-      for j:=i+1 to n do pu^[ii+j]:=0;
-      if g <> 0 then
-        begin
-          h:=pu^[ii+i]*g;
-          for j:=i+1 to n do
-            begin
-              s:=0;
-              for k:=i+1 to m do
-                begin
-                  kk:=(k-1)*rwidthu; s:=s+pu^[kk+i]*pu^[kk+j]
-                end; {k}
-              f:=s/h;
-              for k:=i to m do
-                begin
-                  kk:=(k-1)*rwidthu;
-                  pu^[kk+j]:=pu^[kk+j]+f*pu^[kk+i]
-                end {k}
-            end; {j}
-          for j:=i to m do
-            begin
-              jj:=(j-1)*rwidthu+i; pu^[jj]:=pu^[jj]/g
-            end {j}
-        end {g}
-      else
-        for j:=i to m do pu^[(j-1)*rwidthu+i]:=0;
-      pu^[ii+i]:=pu^[ii+i]+1
-    end; {i}
-  eps:=macheps*x;
-  for k:=n downto 1 do
-    begin
-      conv:=false;
-      repeat
-        l:=k; goon:=true;
-        while goon do
-          begin
-            if abs(e^[l]) <= eps then
-              begin
-                goon:=false; cancel:=false
-              end else
-            if abs(pq^[l-1]) <= eps then
-              begin
-                goon:=false; cancel:=true
-              end else l:=l-1
-          end; {goon}
-        if cancel then
-          begin
-            c:=0; s:=1; i:=l; goon:=true;
-            while goon do
-              begin
-                f:=s*e^[i]; e^[i]:=c*e^[i]; goon:=abs(f) > eps;
-                if goon then
-                  begin
-                    g:=pq^[i]; h:=sqrt(f*f+g*g); pq^[i]:=h;
-                    c:=g/h; s:=-f/h;
-                    for j:=1 to m do
-                      begin
-                        jj:=(j-1)*rwidthu; y:=pu^[jj+l-1]; z:=pu^[jj+i];
-                        pu^[jj+l-1]:=y*c+z*s; pu^[jj+i]:=-y*s+z*c
-                      end; {j}
-                    i:=i+1; goon:=i <= k
-                  end {goon}
-              end {while goon}
-          end; {cancel}
-        z:=pq^[k]; if k=l then conv:=true else
-          begin
-            x:=pq^[l]; y:=pq^[k-1]; g:=e^[k-1]; h:=e^[k];
-            f:=((y-z)*(y+z)+(g-h)*(g+h))/(2*h*y); g:=sqrt(f*f+1);
-            if f < 0 then s:=f-g else s:=f+g;
-            f:=((x-z)*(x+z)+h*(y/s-h))/x;
-            c:=1; s:=1;
-            for i:=l+1 to k do
-              begin
-                g:=e^[i]; y:=pq^[i]; h:=s*g; g:=c*g;
-                z:=sqrt(f*f+h*h); e^[i-1]:=z; c:=f/z; s:=h/z;
-                f:=x*c+g*s; g:=-x*s+g*c; h:=y*s; y:=y*c;
-                for j:=1 to n do
-                  begin
-                    jj:=(j-1)*rwidthv;
-                    x:=pv^[jj+i-1]; z:=pv^[jj+i];
-                    pv^[jj+i-1]:=x*c+z*s; pv^[jj+i]:=-x*s+z*c
-                  end; {j}
-                z:=sqrt(f*f+h*h); pq^[i-1]:=z; c:=f/z; s:=h/z;
-                f:=c*g+s*y; x:=-s*g+c*y;
-                for j:=1 to m do
-                  begin
-                    jj:=(j-1)*rwidthu;
-                    y:=pu^[jj+i-1]; z:=pu^[jj+i];
-                    pu^[jj+i-1]:=y*c+z*s; pu^[jj+i]:=-y*s+z*c
-                  end {j}
-              end; {i}
-            e^[l]:=0; e^[k]:=f; pq^[k]:=x
-          end {k <> l}
-      until conv;
-      if z < 0 then
-        begin
-          pq^[k]:=-z;
-          for j:=1 to n do
-            begin
-              jj:=(j-1)*rwidthv+k; pv^[jj]:=-pv^[jj]
-            end {j}
-        end {z}
-    end; {k}
-  for i:=1 to n do
-    begin
-      k:=i; p:=pq^[i];
-      for j:=i+1 to n do
-        if pq^[j] < p then
-          begin
-            k:=j; p:=pq^[j]
-          end;
-        if k <> i then
-          begin
-            pq^[k]:=pq^[i]; pq^[i]:=p;
-            for j:=1 to m do
-              begin
-                jj:=(j-1)*rwidthu;
-                p:=pu^[jj+i]; pu^[jj+i]:=pu^[jj+k]; pu^[jj+k]:=p;
-              end;
-            for j:=1 to n do
-              begin
-                jj:=(j-1)*rwidthv;
-                p:=pv^[jj+i]; pv^[jj+i]:=pv^[jj+k]; pv^[jj+k]:=p
-              end { interchange in u and v column i with comlumn k }
-          end
-    end; {i}
-  freemem(e, ns)
-end; {eigsv3}
-end.
-
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:43  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:14  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:41  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/eigh1.pas

@@ -1,940 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             Documentation by Michael van Canneyt ([email protected])
-
-    This is a helper unit for the unit eig. The functions aren't documented,
-    so if you find out what it does, please mail it to us.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-unit eigh1;
-{$I DIRECT.INC}
-
-interface
-
-uses typ;
-
-procedure tred1(var a: ArbFloat; n, rwidth: ArbInt; var d, cd: ArbFloat;
-                var term: ArbInt);
-procedure tred2(var a: ArbFloat; n, rwidtha: ArbInt; var d, cd, x: ArbFloat;
-                  rwidthx: ArbInt; var term: ArbInt);
-procedure tql1(var d, cd: ArbFloat; n: ArbInt;
-               var lam: ArbFloat; var term: ArbInt);
-procedure tql2(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;
-               rwidth: ArbInt; var term: ArbInt);
-procedure bisect(var d, cd: ArbFloat; n, k1, k2: ArbInt; eps: ArbFloat;
-                 var lam: ArbFloat; var term: ArbInt);
-procedure trbak1(var a: ArbFloat; n, rwidtha: ArbInt; var cd: ArbFloat;
-                 k1, k2: ArbInt; var x: ArbFloat; rwidthx: ArbInt);
-procedure trsturm1(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;
-                   var x: ArbFloat; rwidth: ArbInt; var m2, term: ArbInt);
-procedure transf(var a: ArbFloat; n, l: ArbInt; var b: ArbFloat; rwidthb: ArbInt);
-procedure bandrd1(var a: ArbFloat; n, m, rwidth: ArbInt; var d, cd: ArbFloat);
-procedure bandrd2(var a: ArbFloat; n, m, rwidtha: ArbInt; var d, cd, x: ArbFloat;
-                  rwidthx: ArbInt);
-procedure bandev(var a: ArbFloat; n, m, rwidth: ArbInt; lambda: ArbFloat;
-                 var v: ArbFloat; var term: ArbInt);
-
-implementation
-
-procedure tred1(var a: ArbFloat; n, rwidth: ArbInt; var d, cd: ArbFloat;
-                var term: ArbInt);
-
-var  i, ii, jj, j, k, l, sr : ArbInt;
-               f, g, h, tol : ArbFloat;
-             pa, pd, pcd : ^arfloat1;
-begin
-  if n<1 then
-  begin
-      term:=3; exit
-  end; {wrong input}
-  pa:=@a; pd:=@d; pcd:=@cd;
-  sr:=sizeof(ArbFloat);
-  tol:=midget/macheps;
-  for i:=1 to n do pd^[i]:=pa^[(i-1)*rwidth+i];
-  for i:=n downto 1 do
-  begin
-      ii:=(i-1)*rwidth; l:=i-2; h:=0;
-      if i=1 then f:=0 else f:=pa^[ii+i-1];
-      for k:=1 to l do h:=h+sqr(pa^[ii+k]);
-      if h <= tol then
-        begin
-          pcd^[i]:=f;
-          for j:=1 to i-1 do pa^[ii+j]:=0;
-        end else
-        begin
-          h:=h+f*f; l:=l+1;
-          if f<0 then g:=sqrt(h) else g:=-sqrt(h);
-          pcd^[i]:=g;
-          h:=h-f*g; pa^[ii+i-1]:=f-g; f:=0;
-          for j:=1 to l do
-            begin
-              g:=0;
-              for k:=1 to j do g:=g+pa^[(j-1)*rwidth+k]*pa^[ii+k];
-              for k:=j+1 to l do g:=g+pa^[(k-1)*rwidth+j]*pa^[ii+k];
-              g:=g/h; pcd^[j]:=g; f:=f+g*pa^[ii+j]
-            end; {j}
-          h:=f/(h+h);
-          for j:=1 to l do
-            begin
-              jj:=(j-1)*rwidth;
-              f:=pa^[ii+j]; pcd^[j]:=pcd^[j]-h*f; g:=pcd^[j];
-              for k:=1 to j do pa^[jj+k]:=pa^[jj+k]-f*pcd^[k]-g*pa^[ii+k]
-            end {j}
-        end;  {h > tol}
-      h:=pd^[i]; pd^[i]:=pa^[ii+i]; pa^[ii+i]:=h
-    end; {i}
-  term:=1
-end; {tred1}
-
-procedure tred2(var a: ArbFloat; n, rwidtha: ArbInt; var d, cd, x: ArbFloat;
-                  rwidthx: ArbInt; var term: ArbInt);
-
-var i, j, k, l, ii, jj, kk : ArbInt;
-         f , g, h, hh, tol : ArbFloat;
-           pa, pd, pcd, px : ^arfloat1;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end;
-  tol:=midget/macheps;
-  pa:=@a; pd:=@d; pcd:=@cd; px:=@x;
-  for i:=1 to n do
-    move(pa^[1+(i-1)*rwidtha], px^[1+(i-1)*rwidthx], i*sizeof(ArbFloat));
-  for i:=n downto 2 do
-    begin
-      l:=i-2; ii:=(i-1)*rwidthx; f:=px^[i-1+ii];
-      g:=0; for k:=1 to l do g:=g+sqr(px^[k+ii]);
-      h:=g+f*f;
-      if g<=tol then
-        begin
-          pcd^[i]:=f; pd^[i]:=0
-        end else
-        begin
-          l:=l+1; if f<0 then g:=sqrt(h) else g:=-sqrt(h);
-          pcd^[i]:=g;
-          h:=h-f*g; px^[i-1+ii]:=f-g; f:=0;
-          for j:=1 to l do
-            begin
-              jj:=(j-1)*rwidthx; px^[i+jj]:=px^[j+ii]/h;
-              g:=0; for k:=1 to j do g:=g+px^[k+jj]*px^[k+ii];
-              for k:=j+1 to l do g:=g+px^[j+(k-1)*rwidthx]*px^[k+ii];
-              pcd^[j]:=g/h; f:=f+g*px^[i+jj]
-            end;
-          hh:=f/(h+h);
-          for j:=1 to l do
-            begin
-              jj:=(j-1)*rwidthx; f:=px^[j+ii];
-              pcd^[j]:=pcd^[j]-hh*f; g:=pcd^[j];
-              for k:=1 to j do px^[k+jj]:=px^[k+jj]-f*pcd^[k]-g*px^[k+ii]
-             end;
-          pd^[i]:=h
-        end
-    end;
-  pd^[1]:=0; pcd^[1]:=0;
-  for i:=1 to n do
-    begin
-      ii:=(i-1)*rwidthx; l:=i-1;
-      if pd^[i] <> 0 then
-        for j:=1 to l do
-          begin
-            g:=0; for k:=1 to l do g:=g+px^[k+ii]*px^[j+(k-1)*rwidthx];
-             for k:=1 to l do
-               begin
-                 kk:=(k-1)*rwidthx; px^[j+kk]:=px^[j+kk]-g*px^[i+kk]
-               end
-          end;
-      pd^[i]:=px^[i+ii]; px^[i+ii]:=1;
-      for j:=1 to l do
-        begin
-          px^[j+ii]:=0; px^[i+(j-1)*rwidthx]:=0
-        end
-    end;
-  term:=1;
-end {tred2};
-
-procedure tql1(var d, cd: ArbFloat; n: ArbInt;
-               var lam: ArbFloat; var term: ArbInt);
-
-var                  i, j, l, m : ArbInt;
-   meps, b, c, f, g, h, p, r, s : ArbFloat;
-                    conv, shift : boolean;
-                  pd, pcd, plam : ^arfloat1;
-
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pd:=@d; pcd:=@cd; plam:=@lam;
-  conv:=true; meps:=macheps;
-  for i:=2 to n do pcd^[i-1]:=pcd^[i];
-  pcd^[n]:=0; f:=0; b:=0; l:=0;
-  while (l<n) and conv do
-    begin
-      l:=l+1; j:=0; h:=meps*(abs(pd^[l])+abs(pcd^[l]));
-      if b<h then b:=h;
-      m:=l-1; repeat m:=m+1 until abs(pcd^[m]) <= b;
-      while (abs(pcd^[l])>b) and conv do
-        begin
-          g:=pd^[l]; p:=(pd^[l+1]-g)/(2*pcd^[l]);
-          if abs(p)>1 then r:=abs(p)*sqrt(1+sqr(1/p)) else r:=sqrt(sqr(p)+1);
-          if p<0 then pd^[l]:=pcd^[l]/(p-r) else pd^[l]:=pcd^[l]/(p+r);
-          h:=g-pd^[l];
-          for i:=l+1 to n do pd^[i]:=pd^[i]-h;
-          f:=f+h; p:=pd^[m]; c:=1; s:=0;
-          for i:=m-1 downto l do
-            begin
-              g:=c*pcd^[i]; h:=c*p;
-              if abs(p) >= abs(pcd^[i]) then
-                begin
-                  c:=pcd^[i]/p; r:=sqrt(c*c+1);
-                  pcd^[i+1]:=s*p*r; s:=c/r; c:=1/r
-                end
-              else
-                begin
-                  c:=p/pcd^[i]; r:=sqrt(c*c+1);
-                  pcd^[i+1]:=s*pcd^[i]*r; s:=1/r; c:=c/r
-                end;
-              p:=c*pd^[i]-s*g; pd^[i+1]:=h+s*(c*g+s*pd^[i])
-            end; {i}
-          pcd^[l]:=s*p; pd^[l]:=c*p; j:=j+1; conv:=j <= 30
-        end; {while}
-      if conv then
-        begin
-          p:=pd^[l]+f; i:=l; shift:=true;
-          while shift and (i>1) do
-            begin
-              if p>=plam^[i-1] then shift:= false else plam^[i]:=plam^[i-1];
-              i:=i-1
-            end; {while}
-          if not shift then plam^[i+1]:=p else plam^[i]:=p
-        end  {if conv}
-    end; {l}
-  if conv then term:=1 else term:=2
-end; {tql1}
-
-procedure tql2(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;
-               rwidth: ArbInt; var term: ArbInt);
-var i, j, k, l, m, kk, ki, ki1, jj, ji, jk, sr, ns, n1s : ArbInt;
-                                                   conv : boolean;
-                           meps, b, c, f, g, h, p, r, s : ArbFloat;
-                            pd, pcd, plam, px, c1d, ccd : ^arfloat1;
-begin
-  if n<1 then
-    begin
-      term:=3; exit
-    end;
-  sr:=sizeof(ArbFloat); ns:=n*sizeof(ArbFloat); n1s:=ns-sr;
-  getmem(c1d, ns); getmem(ccd, ns);
-  pd:=@d; pcd:=@cd; plam:=@lam; px:=@x;
-  move(pcd^[2], ccd^[1], n1s); ccd^[n]:=0; move(pd^[1], c1d^[1], ns);
-  conv:= true; meps:=macheps; f:=0; b:=0; l:=0;
-  while (l<n) and conv do
-    begin
-      l:=l+1; j:=0; h:=meps*(abs(c1d^[l])+abs(ccd^[l]));
-      if b<h then b:=h;
-      m:=l; while abs(ccd^[m])>b do m:=m+1;
-      while (abs(ccd^[l])>b) and conv do
-        begin
-          g:=c1d^[l]; p:=(c1d^[l+1]-g)/(2*ccd^[l]);
-          if abs(p)>1
-          then r:=abs(p)*sqrt(1+sqr(1/p)) else r:=sqrt(sqr(p)+1);
-          if p<0 then c1d^[l]:=ccd^[l]/(p-r) else c1d^[l]:=ccd^[l]/(p+r);
-          h:=g-c1d^[l];
-          for i:=l+1 to n do c1d^[i]:=c1d^[i]-h;
-          f:=f+h; p:=c1d^[m]; c:=1; s:=0;
-          for i:=m-1 downto l do
-            begin
-              g:=c*ccd^[i]; h:=c*p;
-              if abs(p)>=abs(ccd^[i]) then
-                 begin
-                   c:=ccd^[i]/p; r:=sqrt(c*c+1);
-                   ccd^[i+1]:=s*p*r; s:=c/r; c:=1/r
-                 end else
-                begin
-                  c:=p/ccd^[i]; r:=sqrt(c*c+1);
-                  ccd^[i+1]:=s*ccd^[i]*r; s:=1/r; c:=c/r
-                end;
-                p:=c*c1d^[i]-s*g; c1d^[i+1]:=h+s*(c*g+s*c1d^[i]);
-                for k:=1 to n do
-                  begin
-                    kk:=(k-1)*rwidth; ki:=i+kk; ki1:=ki+1;
-                    h:=px^[ki1]; px^[ki1]:=s*px^[ki]+c*h;
-                    px^[ki]:=c*px^[ki]-s*h
-                  end
-              end;
-            ccd^[l]:=s*p; c1d^[l]:=c*p; j:=j+1; conv:=j<=30
-        end;
-      if conv
-      then
-        plam^[l]:=c1d^[l]+f
-    end;
-  if conv then
-    for i:=1 to n do
-      begin
-        k:=i; p:=plam^[i];
-        for j:=i+1 to n do
-          if plam^[j]<p then
-            begin
-              k:=j; p:=plam^[j]
-            end;
-          if k <> i then
-            begin
-              plam^[k]:=plam^[i]; plam^[i]:=p;
-              for j:=1 to n do
-                begin
-                  jj:=(j-1)*rwidth; ji:=i+jj; jk:=k+jj;
-                  p:=px^[ji]; px^[ji]:=px^[jk]; px^[jk]:=p
-                end
-            end
-      end;
-  if conv then term:=1 else term:=2;
-  freemem(c1d, ns); freemem(ccd, ns)
-end; {tql2}
-
-procedure bisect(var d, cd: ArbFloat; n, k1, k2: ArbInt; eps: ArbFloat;
-                 var lam: ArbFloat; var term: ArbInt);
-
-var                  a, i, k, sr : ArbInt;
-    pd, pcd, plam, codsq, xlower : ^arfloat1;
-      meps, eps1, q, xmin, xmax,
-       xl, xu, lambdak, h, diagi : ArbFloat;
-
-begin
-  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  term:=1;
-  pd:=@d; pcd:=@cd; plam:=@lam;
-  sr:=sizeof(ArbFloat);
-  getmem(codsq, n*sr); getmem(xlower, n*sr);
-  meps:=macheps;
-  for i:=2 to n do codsq^[i]:=sqr(pcd^[i]);
-  xmin:=pd^[n]; xmax:=xmin;
-  if n > 1 then
-    begin
-      h:=abs(pcd^[n]); xmin:=xmin-h; xmax:=xmax+h
-    end ;
-  for i:=n-1 downto 1 do
-    begin
-      h:=abs(pcd^[i+1]);
-      if i<>1 then h:=h+abs(pcd^[i]);
-      diagi:=pd^[i];
-      if diagi-h<xmin then xmin:=diagi-h;
-      if diagi+h>xmax then xmax:=diagi+h
-    end; {i}
-  if xmin+xmax>0 then eps1:=meps*xmax
-  else eps1:=-meps*xmin;
-  if eps <= 0 then eps:=eps1;
-  for i:=k1 to k2 do
-    begin
-      plam^[i-k1+1]:=xmax; xlower^[i]:=xmin
-    end;
-  xu:=xmax;
-  for k:=k2 downto k1 do
-    begin
-      if xu>plam^[k-k1+1] then xu:=plam^[k-k1+1];
-      i:=k; repeat xl:=xlower^[i]; i:=i-1 until (i<k1) or (xl>xmin);
-      while xu-xl>2*meps*(abs(xl)+abs(xu))+eps do
-        begin
-          lambdak:=xl+(xu-xl)/2; q:=pd^[1]-lambdak;
-          if q<0 then a:=1 else a:=0;
-          for i:=2 to n do
-            begin
-              if q=0 then q:=meps;
-              q:=pd^[i]-lambdak-codsq^[i]/q;
-              if q<0 then a:=a+1
-            end; {i}
-          if a<k then
-            begin
-              if a<k1 then
-                begin
-                  xl:=lambdak; xlower^[k]:=lambdak
-                end else
-                begin
-                  xl:=lambdak; xlower^[a+1]:=lambdak;
-                  if plam^[a-k1+1]>lambdak then plam^[a-k1+1]:=lambdak
-                end
-            end else xu:=lambdak
-        end; {while}
-      plam^[k-k1+1]:=xl+(xu-xl)/2
-    end;  {k}
-  freemem(codsq, n*sr); freemem(xlower, n*sr)
-end; {bisect}
-
-procedure trbak1(var a: ArbFloat; n, rwidtha: ArbInt; var cd: ArbFloat;
-                 k1, k2: ArbInt; var x: ArbFloat; rwidthx: ArbInt);
-
-var  i, j, k, l, ii, ind : ArbInt;
-                    h, s : ArbFloat;
-             pa, px, pcd : ^arfloat1;
-begin
-  pa:=@a; px:=@x; pcd:=@cd;
-  for i:=3 to n do
-    begin
-      ii:=(i-1)*rwidtha;
-      l:=i-1; h:=pcd^[i]*pa^[ii+i-1];
-      if h <> 0 then
-      for j:=1 to k2-k1+1 do
-        begin
-          s:=0; for k:=1 to l do s:=s+pa^[ii+k]*px^[(k-1)*rwidthx+j]; s:=s/h;
-          for k:=1 to l do
-            begin
-              ind:=(k-1)*rwidthx+j; px^[ind]:=px^[ind]+s*pa^[ii+k]
-            end; {k}
-        end  {j}
-    end  {i}
-end;  {trbak1}
-
-procedure trsturm1(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;
-                   var x: ArbFloat; rwidth: ArbInt; var m2, term: ArbInt);
-
-var
-                     ns, nb, a, i, k, s, its, group, j : ArbInt;
-                                      continu, nonfail : boolean;
-       eps1, eps2, eps3, eps4, q,  xmin, xmax, xl, xu,
-  x1, x0, u, v, norm, meps, lambdak, h, diagi, codiagi : ArbFloat;
-      codsq, d1, e, f, y, z, xlower, pd, pcd, plam, px : ^arfloat1;
-                                                   int : ^arbool1;
-begin
-  if (n<1) or (k1<1) or (k1>k2) or (k2>n) then
-    begin
-      term:=3; exit
-    end; {wrong input}
-  pd:=@d; pcd:=@cd; plam:=@lam; px:=@x;
-  ns:=n*sizeof(ArbFloat); nb:=n*sizeof(boolean);
-  getmem(codsq, ns); getmem(d1, ns); getmem(e, ns); getmem(f, ns);
-  getmem(y, ns); getmem(z, ns); getmem(xlower, ns); getmem(int, nb);
-  meps:=macheps;
-  norm:=abs(pd^[1]);
-  for i:=2 to n do norm:=norm+abs(pd^[i])+abs(pcd^[i]);
-  if norm=0 then
-    begin
-  { matrix is nulmatrix: eigenwaarden zijn alle 0 en aan de
-    eigenvectoren worden de eenheidsvectoren e(k1) t/m e(k2) toegekend }
-      for k:=k1 to k2 do plam^[k-k1+1]:=0;
-      for i:=1 to n do
-        fillchar(px^[(i-1)*rwidth+1], (k2-k1+1)*sizeof(ArbFloat), 0);
-      for k:=k1 to k2 do px^[(k-1)*rwidth+k-k1+1]:=1;
-      m2:=k2; term:=1;
-      freemem(codsq, ns); freemem(d1, ns); freemem(e, ns); freemem(f, ns);
-      freemem(y, ns); freemem(z, ns); freemem(xlower, ns); freemem(int, nb);
-      exit
-    end; {norm=0}
-  for i:=2 to n do codsq^[i]:=sqr(pcd^[i]);
-  xmin:=pd^[n]; xmax:=xmin;
-  if n>1 then
-    begin
-      h:=abs(pcd^[n]); xmin:=xmin-h; xmax:=xmax+h
-    end;
-  for i:=n-1 downto 1 do
-    begin
-      diagi:=pd^[i];
-      h:=abs(pcd^[i+1]);
-      if i<>1 then h:=h+abs(pcd^[i]);
-      if diagi-h<xmin then xmin:=diagi-h;
-      if diagi+h>xmax then xmax:=diagi+h;
-    end; {i}
-  if xmax+xmin>0 then eps1:=meps*xmax else eps1:=-meps*xmin;
-  for i:=k1 to k2 do
-    begin
-      plam^[i-k1+1]:=xmax; xlower^[i]:=xmin
-    end;
-  xu:=xmax;
-  for k:=k2 downto k1 do
-    begin
-      if xu>plam^[k-k1+1] then xu:=plam^[k-k1+1];
-      i:=k; repeat xl:=xlower^[i]; i:=i-1 until (i<k1) or (xl>xmin);
-      while xu-xl>2*eps1 do
-        begin
-          lambdak:=xl+(xu-xl)/2; q:=pd^[1]-lambdak;
-          if q<0 then a:=1 else a:=0;
-          for i:=2 to n do
-            begin
-              if q=0 then q:=meps;
-              q:=pd^[i]-lambdak-codsq^[i]/q;
-              if q<0 then a:=a+1;
-            end; {i}
-          if a<k then
-            begin
-              if a<k1 then
-                begin
-                  xl:=lambdak; xlower^[k]:=lambdak
-                end else
-                begin
-                  xlower^[a+1]:=lambdak; xl:=lambdak;
-                  if plam^[a-k1+1]>lambdak then plam^[a-k1+1]:=lambdak
-                end
-            end else xu:=lambdak
-        end;  {while}
-      plam^[k-k1+1]:=xl+(xu-xl)/2;
-    end; {k}
-  eps2:=norm*1e-3; eps3:=meps*norm; eps4:=eps3*n;
-  group:=0; s:=1; k:=k1; nonfail:=true; m2:=k1-1;
-  while (k <= k2) and nonfail do
-    begin
-      x1:=plam^[k-k1+1];
-      if k <> k1 then
-        begin
-          if x1-x0<eps2 then group:=group+1 else group:=0;
-          if x1 <= x0 then x1:=x0+eps3
-        end; {k <> k1}
-      u:=eps4/sqrt(n);
-      for i:=1 to n do z^[i]:=u;
-      u:=pd^[1]-x1;
-      if n=1 then v:=0 else v:=pcd^[2];
-      for i:=2 to n do
-        begin
-          if pcd^[i]=0 then codiagi:=eps3 else codiagi:=pcd^[i];
-          if abs(codiagi) >= abs(u) then
-            begin
-              xu:=u/codiagi; y^[i]:=xu; d1^[i-1]:=codiagi;
-              e^[i-1]:=pd^[i]-x1;
-              if i=n then f^[i-1]:=0 else f^[i-1]:=pcd^[i+1];
-              u:=v-xu*e^[i-1]; v:=-xu*f^[i-1];
-              int^[i]:=true
-            end else
-            begin
-              xu:=codiagi/u; y^[i]:=xu; d1^[i-1]:=u; e^[i-1]:=v;
-              f^[i-1]:=0; u:=pd^[i]-x1-xu*v;
-              if i<n then v:=pcd^[i+1];
-              int^[i]:=false
-            end
-        end;  {i}
-      if u=0 then d1^[n]:=eps3 else d1^[n]:=u;
-      e^[n]:=0; f^[n]:=0;
-      its:=1; continu:=true;
-      while continu and nonfail do
-        begin
-          for i:=n downto 1 do
-            begin
-              z^[i]:=(z^[i]-u*e^[i]-v*f^[i])/d1^[i]; v:=u; u:=z^[i]
-            end;
-          for j:=m2-group+1 to m2 do
-            begin
-              xu:=0;
-              for i:=1 to n do xu:=xu+z^[i]*px^[(i-1)*rwidth+j-k1+1];
-              for i:=1 to n do z^[i]:=z^[i]-xu*px^[(i-1)*rwidth+j-k1+1]
-            end; {j}
-          norm:=0; for i:=1 to n do norm:=norm+abs(z^[i]);
-          if norm<1 then
-            begin
-              if norm=0 then
-                begin
-                  z^[s]:=eps4;
-                  if s<n then s:=s+1 else s:=1
-                end else
-                begin
-                  xu:=eps4/norm;
-                  for i:=1 to n do z^[i]:=z^[i]*xu
-                end;
-              for i:=2 to n do
-                if int^[i] then
-                  begin
-                    u:=z^[i-1]; z^[i-1]:=z^[i]; z^[i]:=u-y^[i]*z^[i]
-                  end else z^[i]:=z^[i]-y^[i]*z^[i-1];
-              its:=its+1; if its=5 then nonfail:=false;
-            end {norm < 1}
-          else continu:=false
-        end; {while continu ^ nonfail}
-      if nonfail then
-        begin
-          u:=0; for i:=1 to n do u:=u+sqr(z^[i]);
-          xu:=1/sqrt(u); m2:=m2+1;
-          for i:=1 to n do px^[(i-1)*rwidth+m2-k1+1]:=z^[i]*xu;
-          x0:=x1; k:=k+1;
-        end
-    end;  {k}
-  if m2=k2 then term:=1 else term:=2;
-  freemem(codsq, ns); freemem(d1, ns); freemem(e, ns); freemem(f, ns);
-  freemem(y, ns); freemem(z, ns); freemem(xlower, ns); freemem(int, nb);
-end  {trsturm1};
-
-procedure transf(var a: ArbFloat; n, l: ArbInt; var b: ArbFloat; rwidthb: ArbInt);
-
-{ a bevat de linksonder bandelementen van een symmetrische matrix A met
- lengte n en bandbreedte l, rijsgewijs aaneengesloten.
- na afloop bevatten de kolommen van b de diagonalen van A, met dien
- vestande dat de hoofddiagonaal van A in de eerste kolom van b staat,
- de een na langste codiagonaal in de tweede kolom
- (behalve de onderste plaats) enzovoort.
- De niet opgevulde plaatsen komen in b dus rechtsonder te staan. }
-
-var             pa, pb: ^arfloat1;
-     ii, jj, i, j, rwa: ArbInt;
-begin
-  pa:=@a; pb:=@b;
-  ii:=1; jj:=0;
-  for i:=1 to n do
-  begin
-    if i>l then rwa:=l+1 else rwa:=i;
-    if i>l+1 then jj:=jj+rwidthb else jj:=jj+1;
-    for j:=1 to rwa do pb^[jj+(j-1)*(rwidthb-1)]:=pa^[ii+j-1];
-    ii:=ii+rwa;
-  end
-end;
-
-procedure banddek(n, m1, m2: ArbInt; var au, l: ArbFloat; var p: ArbInt);
-var                      pa, pl, norm: ^arfloat1;
-                                   pp: ^arint1;
-    i, j, ll, ii, k, t, pk, ind, ind1: ArbInt;
-                   piv, c, x, maxnorm: ArbFloat;
-begin
-   pa:=@au; pl:=@l; pp:=@p;
-   getmem(norm, n*sizeof(ArbFloat));
-   t:=m1; ll:=m1+m2+1;
-   for i:=1 to m1 do
-   begin
-     ind:=(i-1)*ll;
-     for j:=m1+1-i to ll do pa^[ind+j-t]:=pa^[ind+j];
-     t:=t-1;
-     for j:=ll-t to ll do pa^[ind+j]:=0
-   end;
-   t:=1;
-   for i:=n downto n-m2+1 do
-   begin
-     ind:=(i-1)*ll;
-     for j:=t+m1+1 to ll do pa^[ind+j]:=0;
-     t:=t+1
-   end;
-   maxnorm:=0;
-   for k:=1 to n do
-   begin
-     c:=0; ind:=(k-1)*ll;
-     for j:=1 to ll do c:=c+abs(pa^[ind+j]);
-     if c>maxnorm then maxnorm:=c;
-     if c=0 then norm^[k]:=1 else norm^[k]:=c
-   end;
-   t:=m1;
-   for k:=1 to n do
-   begin
-     ind:=(k-1)*ll;
-     x:=abs(pa^[ind+1])/norm^[k]; pk:=k;
-     t:=t+1; if t>n then t:=n;
-     for i:=k+1 to t do
-     begin
-       c:=abs(pa^[(i-1)*ll+1])/norm^[i];
-       if c>x then
-       begin
-         x:=c; pk:=i
-       end
-     end;
-     ind1:=(pk-1)*ll;
-     pp^[k]:=pk;
-     if pk <> k then
-     begin
-       for j:=1 to ll do
-       begin
-         c:=pa^[ind+j]; pa^[ind+j]:=pa^[ind1+j]; pa^[ind1+j]:=c
-       end;
-       norm^[pk]:=norm^[k]
-     end;
-     piv:=pa^[ind+1];
-     if piv <> 0 then
-     begin
-       for i:=k+1 to t do
-       begin
-         ii:=(i-1)*ll;
-         c:=pa^[ii+1]/piv; pl^[(k-1)*m1+i-k]:=c;
-         for j:=2 to ll do pa^[ii+j-1]:=pa^[ii+j]-c*pa^[ind+j];
-         pa^[ii+ll]:=0
-       end
-     end else
-     begin
-       pa^[ind+1]:=macheps*maxnorm;
-       for i:=k+1 to t do
-       begin
-         ii:=(i-1)*ll;
-         pl^[(k-1)*m1+i-k]:=0;
-         for j:=2 to ll do pa^[ii+j-1]:=pa^[ii+j];
-         pa^[ii+ll]:=0
-       end {i}
-     end {piv=0}
-   end; {k}
-  freemem(norm, n*sizeof(ArbFloat))
-end; {banddek}
-
-procedure bandsol(n, m1, m2: ArbInt; var au, l: ArbFloat;
-                  var p: ArbInt; var b: ArbFloat);
-var          pa, pl, pb: ^arfloat1;
-                     pp: ^arint1;
-  ll, i, j, k, pk, t, w: ArbInt;
-                      x: ArbFloat;
-begin
-  pa:=@au; pl:=@l; pb:=@b; pp:=@p;
-  for k:=1 to n do
-  begin
-    pk:=pp^[k];
-    if pk <> k then
-    begin
-      x:=pb^[k]; pb^[k]:=pb^[pk]; pb^[pk]:=x
-    end;
-    t:=k+m1; if t>n then t:=n;
-    for i:=k+1 to t do pb^[i]:=pb^[i]-pl^[(k-1)*m1+i-k]*pb^[k]
-  end; {k}
-  t:=1; ll:=m1+m2+1;
-  for i:=n downto 1 do
-  begin
-    x:=pb^[i]; w:=i-1;
-    for j:=2 to t do x:=x-pa^[(i-1)*ll+j]*pb^[j+w];
-    pb^[i]:=x/pa^[(i-1)*ll+1];
-    if t<ll then t:=t+1
-  end {i}
-end; {bandsol}
-
-procedure bandrd1(var a: ArbFloat; n, m, rwidth: ArbInt; var d, cd: ArbFloat);
-
-{ wilkinson linear algebra ii/8 procedure bandrd; matv = false }
-
-var      j, k, l, r, maxr, maxl, ugl, ikr, jj, jj1, i, ll : ArbInt;
-                            b, c, s, s2, c2, cs, u, u1, g : ArbFloat;
-                                              pa, pd, pcd : ^arfloat1;
-begin
-  pa:=@a; pd:=@d; pcd:=@cd;
-  for k:=1 to n-2 do
-    begin
-      if n-k<m then maxr:=n-k else maxr:=m;
-      for r:=maxr downto 2 do
-        begin
-          ikr:=(k-1)*rwidth+r+1; g:=pa^[ikr]; j:=k+r;
-          while (g <> 0) and (j <= n) do
-            begin
-              if j=k+r then
-                begin
-                  b:=-pa^[ikr-1]/pa^[ikr]; ugl:=k
-                end else
-                begin
-                  b:=-pa^[(j-m-2)*rwidth+m+1]/g; ugl:=j-m
-                end;
-              s:=1/sqrt(1+b*b); c:=b*s; c2:=c*c; s2:=s*s; cs:=c*s;
-              jj:=(j-1)*rwidth+1; jj1:=jj-rwidth;
-              u:=c2*pa^[jj1]-2*cs*pa^[jj1+1]+s2*pa^[jj];
-              u1:=s2*pa^[jj1]+2*cs*pa^[jj1+1]+c2*pa^[jj];
-              pa^[jj1+1]:=cs*(pa^[jj1]-pa^[jj])+(c2-s2)*pa^[jj1+1];
-              pa^[jj1]:=u; pa^[jj]:=u1;
-              for l:=ugl to j-2 do
-                begin
-                  ll:=(l-1)*rwidth+j-l+1;
-                  u:=c*pa^[ll-1]-s*pa^[ll];
-                  pa^[ll]:=s*pa^[ll-1]+c*pa^[ll];
-                  pa^[ll-1]:=u;
-                end; {l}
-              if j <> k+r then
-                begin
-                  i:=(j-m-2)*rwidth+m+1; pa^[i]:=c*pa^[i]-s*g
-                end;
-              if n-j < m-1 then maxl:=n-j else maxl:=m-1;
-              for l:=1 to maxl do
-                begin
-                  u:=c*pa^[jj1+l+1]-s*pa^[jj+l];
-                  pa^[jj+l]:=s*pa^[jj1+l+1]+c*pa^[jj+l];
-                  pa^[jj1+l+1]:=u
-                end; {l}
-              if j+m <= n then
-                begin
-                  g:=-s*pa^[jj+m]; pa^[jj+m]:=c*pa^[jj+m]
-                end;
-              j:=j+m;
-            end {j}
-        end {r}
-    end; {k}
-  pd^[1]:=pa^[1]; pcd^[1]:=0;
-  for j:=2 to n do
-    begin
-      pd^[j]:=pa^[(j-1)*rwidth+1];
-      if m>0 then pcd^[j]:=pa^[(j-2)*rwidth+2] else pcd^[j]:=0
-    end {j}
-end; {bandrd1}
-
-procedure bandrd2(var a: ArbFloat; n, m, rwidtha: ArbInt; var d, cd, x: ArbFloat;
-                  rwidthx: ArbInt);
-
-{ wilkinson linear algebra ii/8 procedure bandrd; matv = true }
-
-var      j, k, l, r, maxr, maxl, ugl, ikr, jj, jj1, i, ll, ns : ArbInt;
-                                b, c, s, s2, c2, cs, u, u1, g : ArbFloat;
-                                              pa, pd, pcd, px : ^arfloat1;
-begin
-  pa:=@a; pd:=@d; pcd:=@cd; px:=@x; ns:=n*sizeof(ArbFloat);
-  for j:=1 to n do fillchar(px^[(j-1)*rwidthx+1], ns, 0);
-  for j:=1 to n do px^[(j-1)*rwidthx+j]:=1;
-  for k:=1 to n-2 do
-    begin
-      if n-k<m then maxr:=n-k else maxr:=m;
-      for r:=maxr downto 2 do
-        begin
-          ikr:=(k-1)*rwidtha+r+1; g:=pa^[ikr]; j:=k+r;
-          while (g <> 0) and (j <= n) do
-            begin
-              if j=k+r then
-                begin
-                  b:=-pa^[ikr-1]/pa^[ikr]; ugl:=k
-                end else
-                begin
-                  b:=-pa^[(j-m-2)*rwidtha+m+1]/g; ugl:=j-m
-                end;
-              s:=1/sqrt(1+b*b); c:=b*s; c2:=c*c; s2:=s*s; cs:=c*s;
-              jj:=(j-1)*rwidtha+1; jj1:=jj-rwidtha;
-              u:=c2*pa^[jj1]-2*cs*pa^[jj1+1]+s2*pa^[jj];
-              u1:=s2*pa^[jj1]+2*cs*pa^[jj1+1]+c2*pa^[jj];
-              pa^[jj1+1]:=cs*(pa^[jj1]-pa^[jj])+(c2-s2)*pa^[jj1+1];
-              pa^[jj1]:=u; pa^[jj]:=u1;
-              for l:=ugl to j-2 do
-                begin
-                  ll:=(l-1)*rwidtha+j-l+1; u:=c*pa^[ll-1]-s*pa^[ll];
-                  pa^[ll]:=s*pa^[ll-1]+c*pa^[ll]; pa^[ll-1]:=u;
-                end; {l}
-              if j <> k+r then
-                begin
-                  i:=(j-m-2)*rwidtha+m+1; pa^[i]:=c*pa^[i]-s*g
-                end;
-              if n-j < m-1 then maxl:=n-j else maxl:=m-1;
-              for l:=1 to maxl do
-                begin
-                  u:=c*pa^[jj1+l+1]-s*pa^[jj+l];
-                  pa^[jj+l]:=s*pa^[jj1+l+1]+c*pa^[jj+l];
-                  pa^[jj1+l+1]:=u
-                end; {l}
-              if j+m <= n then
-                begin
-                  g:=-s*pa^[jj+m]; pa^[jj+m]:=c*pa^[jj+m]
-                end;
-              for l:=1 to n do
-                begin
-                  ll:=(l-1)*rwidthx+j; u:=c*px^[ll-1]-s*px^[ll];
-                  px^[ll]:=s*px^[ll-1]+c*px^[ll]; px^[ll-1]:=u
-                end; {ll}
-              j:=j+m;
-            end {j}
-        end {r}
-    end; {k}
-  pd^[1]:=pa^[1]; pcd^[1]:=0;
-  for j:=2 to n do
-    begin
-      pd^[j]:=pa^[(j-1)*rwidtha+1];
-      if m>0 then pcd^[j]:=pa^[(j-2)*rwidtha+2] else pcd^[j]:=0
-    end {j}
-end; {bandrd2}
-
-procedure bandev(var a: ArbFloat; n, m, rwidth: ArbInt; lambda: ArbFloat;
-                 var v: ArbFloat; var term: ArbInt);
-
-var                              pa, pv, au, l, u : ^arfloat1;
-                                                p : ^arint1;
-          ind, ii, i, k, t, j, its, w, sr, ns, ll : ArbInt;
-    meps, eps, s, norm, lambdak, x, y, r1, d1, ca : ArbFloat;
-begin
-  pa:=@a; pv:=@v;
-  sr:=sizeof(ArbFloat); ns:=n*sr; ll:=2*m+1;
-  getmem(au, ll*ns); getmem(l, m*ns); getmem(u, ns);
-  getmem(p, n*sizeof(ArbInt));
-  norm:=0; meps:=macheps;
-  for i:=1 to n do
-    begin
-      s:=0; if i-m<1 then k:=i-1 else k:=m; ii:=(i-1)*rwidth;
-      if n-i<m then w:=n-i+1 else w:=m+1;
-      for j:=1 to w do s:=s+abs(pa^[ii+j]);
-      for j:=1 to k do s:=s+abs(pa^[(i-j-1)*rwidth+j+1]);
-      if s>norm then norm:=s
-    end; {norm}
-  eps:=norm*meps;
-  if eps<midget then
-    begin
-      pv^[1]:=1;
-      for j:=2 to n do pv^[j]:=0;
-      term:=1;
-      freemem(au, ll*ns); freemem(l, m*ns); freemem(u, ns);
-      freemem(p, n*sizeof(ArbInt));
-      exit
-    end; {eps<midget}
-  for i:=1 to n do
-    begin
-      if n-i<m then w:=n-i else w:=m;
-      ind:=(i-1)*ll; ii:=(i-1)*rwidth;
-      move(pa^[ii+2], au^[ind+m+2], w*sr);
-      fillchar(au^[ind+m+w+2], (m-w)*sr, 0);
-      if i-1<m then w:=i-1 else w:=m;
-      for j:=1 to w do au^[ind+m-j+1]:=pa^[(i-j-1)*rwidth+j+1];
-      fillchar(au^[ind+1], (m-w)*sr, 0);
-      au^[ind+m+1]:=pa^[ii+1]-lambda
-    end; {i}
-  banddek(n, m, m, au^[1], l^[1], p^[1]);
-  t:=-m;
-  for i:=n downto 1 do
-    begin
-      ind:=(i-1)*ll;
-      x:=1; w:=i+m;
-      for j:=1-m to t do x:=x-au^[ind+m+j+1]*pv^[j+w];
-      pv^[i]:=x/au^[ind+1];
-      if t<m then t:=t+1
-    end; {i}
-  x:=0;
-  for i:=1 to n do
-    if abs(pv^[i])>abs(x) then
-      begin
-        x:=pv^[i]; j:=i
-      end;
-  its:=0; x:=1/x;
-  for i:=1 to n do
-    begin
-      u^[i]:=x*pv^[i]; pv^[i]:=u^[i]
-    end; {i}
-  repeat
-    bandsol(n, m, m, au^[1], l^[1], p^[1], pv^[1]);
-    y:=1/pv^[j]; x:=0;
-    for i:=1 to n do
-      if abs(pv^[i])>abs(x) then
-        begin
-          x:=pv^[i]; j:=i
-        end; {i}
-    x:=1/x; d1:=0;
-    for i:=1 to n do
-      begin
-        r1:=abs((u^[i]-y*pv^[i])*x);
-        if r1>d1 then d1:=r1; u^[i]:=x*pv^[i]; pv^[i]:=u^[i]
-      end; {i}
-    its:=its+1
-  until (d1<=eps) or (its>5);
-  if d1<=eps then
-    begin
-      term:=1; x:=0; for i:=1 to n do x:=x+sqr(pv^[i]); x:=1/sqrt(x);
-      for i:=1 to n do pv^[i]:=pv^[i]*x;
-    end else term:=2;
-  freemem(au, ll*ns); freemem(l, m*ns); freemem(u, ns);
-  freemem(p, n*sizeof(ArbInt));
-end; {bandev}
-end.
-
-
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:43  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:14  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:41  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/eigh2.pas

@@ -1,867 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             Documentation by Michael van Canneyt ([email protected])
-
-    This is a helper unit for the unit eig. These functions aren't documented,
-    so if you find out what it does, please mail it to us.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-unit eigh2;
-{$I DIRECT.INC}
-
-interface
-
-uses typ;
-
-procedure orthes(var a: ArbFloat; n, rwidth: ArbInt; var u: ArbFloat);
-procedure hessva(var h: ArbFloat; n, rwidth: ArbInt; var lam: complex;
-                 var term: ArbInt);
-procedure balance(var a: ArbFloat; n, rwidtha: ArbInt; var low, hi: ArbInt;
-                  var d: ArbFloat);
-procedure orttrans(var a: ArbFloat; n, rwidtha: ArbInt; var q: ArbFloat;
-                   rwidthq: ArbInt);
-procedure balback(var pd: ArbFloat; n, m1, m2, k1, k2: ArbInt; var pdx: ArbFloat;
-                  rwidth: ArbInt);
-procedure hessvec(var h: ArbFloat; n, rwidthh: ArbInt; var lam: complex;
-                  var v: ArbFloat; rwidthv: ArbInt; var term: ArbInt);
-procedure normeer(var lam: complex; n: ArbInt; var v: ArbFloat;
-                  rwidthv: ArbInt);
-procedure transx(var v: ArbFloat; n, rwidthv: ArbInt; var lam, x: complex;
-                 rwidthx: ArbInt);
-procedure reduc1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var term: ArbInt);
-procedure rebaka(var l: ArbFloat; n, rwidthl, k1, k2: ArbInt; var x: ArbFloat;
-                 rwidthx: ArbInt; var term: ArbInt);
-
-implementation
-
-procedure orthes(var a: ArbFloat; n, rwidth: ArbInt; var u: ArbFloat);
-var               pa, pu, d : ^arfloat1;
-    sig, sig2, h, f, g, tol : ArbFloat;
-                    k, i, j : ArbInt;
-begin
-  pa:=@a; pu:=@u; tol:=midget/macheps;
-  getmem(d, n*sizeof(ArbFloat));
-  for k:=1 to n-2 do
-    begin
-      sig2:=0;
-      for i:=k+2 to n do
-        begin
-          d^[i]:=pa^[(i-1)*rwidth+k]; f:=d^[i]; sig2:=sig2+sqr(f)
-        end; {i}
-      if sig2<tol then
-        begin
-          pu^[k]:=0; for i:=k+2 to n do pa^[(i-1)*rwidth+k]:=0
-        end else
-        begin
-          f:=pa^[k*rwidth+k]; sig2:=sig2+sqr(f);
-          if f<0 then sig:=sqrt(sig2) else sig:=-sqrt(sig2);
-          pa^[k*rwidth+k]:=sig;
-          h:=sig2-f*sig; d^[k+1]:=f-sig; pu^[k]:=d^[k+1];
-          for j:=k+1 to n do
-          begin
-            f:=0; for i:=k+1 to n do f:=f+d^[i]*pa^[(i-1)*rwidth+j]; f:=f/h;
-           for i:=k+1 to n do pa^[(i-1)*rwidth+j]:=pa^[(i-1)*rwidth+j]-f*d^[i]
-          end; {j}
-          for i:=1 to n do
-          begin
-            f:=0; for j:=k+1 to n do f:=f+d^[j]*pa^[(i-1)*rwidth+j]; f:=f/h;
-           for j:=k+1 to n do pa^[(i-1)*rwidth+j]:=pa^[(i-1)*rwidth+j]-f*d^[j]
-          end {i}
-        end
-    end;  {k}
-  freemem(d, n*sizeof(ArbFloat));
-end  {orthes};
-
-procedure hessva(var h: ArbFloat; n, rwidth: ArbInt; var lam: complex;
-                 var term: ArbInt);
-var   i, j, k, kk, k1, k2, k3, l, m, mr,
-                ik, nn, na, n1, n2, its : ArbInt;
-        meps, p, q, r, s, t, w, x, y, z : ArbFloat;
-                          test, notlast : boolean;
-                                     ph : ^arfloat1;
-                                   plam : ^arcomp1;
-begin
-  ph:=@h; plam:=@lam;
-  t:=0; term:=1; meps:=macheps; nn:=n;
-  while (nn >= 1) and (term=1) do
-    begin
-      n1:=(nn-1)*rwidth; na:=nn-1; n2:=(na-1)*rwidth;
-      its:=0;
-      repeat
-        l:=nn+1; test:=true;
-        while test and (l>2) do
-          begin
-            l:=l-1;
-            test:=abs(ph^[(l-1)*(rwidth+1)]) >
-                  meps*(abs(ph^[(l-2)*rwidth+l-1])+abs(ph^[(l-1)*rwidth+l]))
-          end;
-        if (l=2) and  test then l:=l-1;
-        if l<na then
-          begin
-            x:=ph^[n1+nn]; y:=ph^[n2+na]; w:=ph^[n1+na]*ph^[n2+nn];
-            if (its=10) or (its=20) then
-              begin
-                {form exceptional shift}
-                t:=t+x;
-                for i:=1 to nn do ph^[(i-1)*rwidth+i]:=ph^[(i-1)*rwidth+i]-x;
-                s:=abs(ph^[n1+na])+abs(ph^[n1+nn-2]);
-                y:=0.75*s; x:=y; w:=-0.4375*sqr(s);
-              end; {shift}
-            {look for two consecutive small sub-diag elmts}
-            m:=nn-1; test:= true ;
-            repeat
-              m:=m-1; mr:=m*rwidth;
-              z:=ph^[mr-rwidth+m]; r:=x-z; s:=y-z;
-              p:=(r*s-w)/ph^[mr+m]+ph^[mr-rwidth+m+1];
-              q:=ph^[mr+m+1]-z-r-s; r:=ph^[mr+rwidth+m+1];
-              s:=abs(p)+abs(q)+abs(r); p:=p/s; q:=q/s; r:=r/s;
-              if m <> l then
-                test:=abs(ph^[mr-rwidth+m-1])*(abs(q)+abs(r)) <=
-                      meps*abs(p)*(abs(ph^[mr-2*rwidth+m-1])+abs(z)+
-                                                    abs(ph^[mr+m+1]))
-            until (m=l) or test;
-            for i:=m+2 to nn do ph^[(i-1)*rwidth+i-2]:=0;
-            for i:=m+3 to nn do ph^[(i-1)*rwidth+i-3]:=0;
-            { double qp-step involving rows l to nn and columns m to nn}
-            for k:=m to na do
-              begin
-                notlast:=k <> na;
-                if k <> m then
-                  begin
-                    p:=ph^[(k-1)*(rwidth+1)]; q:=ph^[k*rwidth+k-1];
-                    if notlast then r:=ph^[(k+1)*rwidth+k-1] else r:=0;
-                    x:=abs(p)+abs(q)+abs(r);
-                    if x>0 then
-                      begin
-                        p:=p/x; q:=q/x; r:=r/x
-                      end
-                  end else x:=1;
-                if x>0 then
-                begin
-                  s:=sqrt(p*p+q*q+r*r); if p<0 then s:=-s;
-                  if k <> m then ph^[(k-1)*(rwidth+1)]:=-s*x else
-                  if l <> m then
-                    begin
-                      kk:=(k-1)*(rwidth+1); ph^[kk]:=-ph^[kk]
-                    end;
-                  p:=p+s; x:=p/s; y:=q/s; z:=r/s; q:=q/p; r:=r/p;
-                  { row moxification}
-                  for j:=k to nn do
-                    begin
-                      k1:=(k-1)*rwidth+j; k2:=k1+rwidth; k3:=k2+rwidth;
-                      p:=ph^[k1]+q*ph^[k2];
-                      if notlast then
-                        begin
-                          p:=p+r*ph^[k3]; ph^[k3]:=ph^[k3]-p*z;
-                        end;
-                      ph^[k2]:=ph^[k2]-p*y; ph^[k1]:=ph^[k1]-p*x;
-                    end;  {j}
-                  if k+3<nn then j:=k+3 else j:=nn;
-                  { column modification}
-                  for i:=l to j do
-                    begin
-                      ik:=(i-1)*rwidth+k;
-                      p:=x*ph^[ik]+y*ph^[ik+1];
-                      if notlast then
-                        begin
-                          p:=p+z*ph^[ik+2]; ph^[ik+2]:=ph^[ik+2]-p*r;
-                        end;
-                      ph^[ik+1]:=ph^[ik+1]-p*q; ph^[ik]:=ph^[ik]-p;
-                    end  {i}
-                end  {x <> 0}
-              end  {k};
-          end;  {l < na}
-        its:=its+1
-      until (l=na) or (l=nn) or (its=30);
-      if l=nn then
-        begin  { one root found}
-          plam^[nn].Init(ph^[n1+nn]+t, 0); nn:=na
-        end else
-      if l=na then
-        begin  { two roots found}
-          x:=ph^[n1+nn]; y:=ph^[n2+na]; w:=ph^[n1+na]*ph^[n2+nn];
-          p:=(y-x)/2; q:=p*p+w; y:=sqrt(abs(q)); x:=x+t;
-          if q>0 then
-            begin  {  ArbFloat pair}
-              if p<0 then y:=-y; y:=p+y;
-              plam^[na].Init(x+y, 0); plam^[nn].Init(x-w/y, 0)
-            end else
-            begin { complex pair}
-              plam^[na].Init(x+p, y); plam^[nn].Init(x+p, -y)
-            end;
-          nn:=nn-2
-        end else term:=2
-    end {while }
-end  {hessva};
-
-procedure balance(var a: ArbFloat; n, rwidtha: ArbInt; var low, hi: ArbInt;
-                  var d: ArbFloat);
-
-const radix = 2;
-
-var   i, j, k, l, ii, jj: ArbInt;
-    b2, b, c, f, g, r, s: ArbFloat;
-                  pa, pd: ^arfloat1;
-           nonconv, cont: boolean;
-
-  procedure exc(j, k: ArbInt);
-  var i, ii, jj, kk: ArbInt;
-                  h: ArbFloat;
-  begin
-    pd^[k]:=j;
-    if j <> k then
-      begin
-        for i:=1 to n do
-          begin
-            ii:=(i-1)*rwidtha;
-            h:=pa^[ii+j]; pa^[ii+j]:=pa^[ii+k]; pa^[ii+k]:=h
-          end; {i}
-        for i:=1 to n do
-          begin
-            jj:=(j-1)*rwidtha+i; kk:=(k-1)*rwidtha+i;
-            h:=pa^[jj]; pa^[jj]:=pa^[kk]; pa^[kk]:=h
-         end; {i}
-     end {j <> k}
-  end {exc};
-begin
-  pa:=@a; pd:=@d; b:=radix; b2:=b*b; l:=1; k:=n; cont:=true;
-  while cont do
-    begin
-      j:=k+1;
-      repeat
-        j:=j-1; r:=0; jj:=(j-1)*rwidtha;
-        for i:=1 to j-1 do r:=r+abs(pa^[jj+i]);
-        for i:=j+1 to k do r:=r+abs(pa^[jj+i]);
-      until (r=0) or (j=1);
-      if r=0 then
-        begin
-          exc(j,k); k:=k-1
-        end;
-      cont:=(r=0) and (k >= 1);
-    end;
-  cont:= true ;
-  while cont do
-    begin
-      j:=l-1;
-      repeat
-        j:=j+1; r:=0;
-        for i:=l to j-1 do r:=r+abs(pa^[(i-1)*rwidtha+j]);
-        for i:=j+1 to k do r:=r+abs(pa^[(i-1)*rwidtha+j])
-      until (r=0) or (j=k);
-      if r=0 then
-        begin
-          exc(j,l); l:=l+1
-        end;
-      cont:=(r=0) and (l <= k);
-    end;
-  for i:=l to k do pd^[i]:=1;
-  low:=l; hi:=k; nonconv:=l <= k;
-  while nonconv do
-    begin
-      for i:=l to k do
-        begin
-          c:=0; r:=0;
-          for j:=l to i-1 do
-            begin
-              c:=c+abs(pa^[(j-1)*rwidtha+i]);
-              r:=r+abs(pa^[(i-1)*rwidtha+j])
-            end;
-          for j:=i+1 to k do
-            begin
-              c:=c+abs(pa^[(j-1)*rwidtha+i]);
-              r:=r+abs(pa^[(i-1)*rwidtha+j])
-            end;
-          g:=r/b; f:=1; s:=c+r;
-          while c<g do
-            begin
-              f:=f*b; c:=c*b2
-            end;
-          g:=r*b;
-          while c >= g do
-            begin
-              f:=f/b; c:=c/b2
-            end;
-          if (c+r)/f<0.95*s then
-            begin
-              g:=1/f; pd^[i]:=pd^[i]*f; ii:=(i-1)*rwidtha;
-              for j:=l to n do pa^[ii+j]:=pa^[ii+j]*g;
-              for j:=1 to k do pa^[(j-1)*rwidtha+i]:=pa^[(j-1)*rwidtha+i]*f;
-            end else nonconv:=false
-        end
-     end {while}
-end; {balance}
-
-procedure orttrans(var a: ArbFloat; n, rwidtha: ArbInt; var q: ArbFloat;
-                   rwidthq: ArbInt);
-
-var                 i, j, k : ArbInt;
-    sig, sig2, f, g, h, tol : ArbFloat;
-                  pa, pq, d : ^arfloat1;
-
-begin
-  pa:=@a; pq:=@q; tol:=midget/macheps;
-  getmem(d, n*sizeof(ArbFloat));
-  for k:=1 to n-2 do
-    begin
-      sig2:=0;
-      for i:=k+2 to n do
-        begin
-          d^[i]:=pa^[(i-1)*rwidtha+k]; f:=d^[i]; sig2:=sig2+sqr(f)
-        end;
-      if sig2<tol then
-        begin
-          d^[k+1]:=0; for i:=k+2 to n do pa^[(i-1)*rwidtha+k]:=0
-        end else
-        begin
-          f:=pa^[k*rwidtha+k]; sig2:=sig2+sqr(f);
-          if f<0 then sig:=sqrt(sig2) else sig:=-sqrt(sig2);
-          pa^[k*rwidtha+k]:=sig; h:=sig2-f*sig; d^[k+1]:=f-sig;
-          for j:=k+1 to n do
-            begin
-              f:=0; for i:=k+1 to n do f:=f+d^[i]*pa^[(i-1)*rwidtha+j];
-              f:=f/h;
-              for i:=k+1 to n do
-                pa^[(i-1)*rwidtha+j]:=pa^[(i-1)*rwidtha+j]-f*d^[i];
-            end;
-          for i:=1 to n do
-            begin
-              f:=0; for j:=k+1 to n do f:=f+d^[j]*pa^[(i-1)*rwidtha+j];
-              f:=f/h;
-              for j:=k+1 to n do
-                pa^[(i-1)*rwidtha+j]:=pa^[(i-1)*rwidtha+j]-f*d^[j];
-            end
-        end
-    end; {k}
-  for i:=1 to n do
-    begin
-      pq^[(i-1)*rwidthq+i]:=1;
-      for j:=1 to i-1 do
-        begin
-          pq^[(i-1)*rwidthq+j]:=0; pq^[(j-1)*rwidthq+i]:=0
-        end
-    end;
-  for k:=n-2 downto 1 do
-    begin
-      h:=pa^[k*rwidtha+k]*d^[k+1];
-      if h <> 0
-      then
-        begin
-          for i:=k+2 to n do d^[i]:=pa^[(i-1)*rwidtha+k];
-          for i:=k+2 to n do pa^[(i-1)*rwidtha+k]:=0;
-          for j:=k+1 to n do
-            begin
-              f:=0; for i:=k+1 to n do f:=f+d^[i]*pq^[(i-1)*rwidthq+j];
-              f:=f/h;
-              for i:=k+1 to n do
-                pq^[(i-1)*rwidthq+j]:=pq^[(i-1)*rwidthq+j]+f*d^[i]
-            end
-        end
-    end;
-  freemem(d, n*sizeof(ArbFloat));
-end; {orttrans}
-
-procedure balback(var pd: ArbFloat; n, m1, m2, k1, k2: ArbInt; var pdx: ArbFloat;
-                  rwidth: ArbInt);
-
-var i, j, k, ii, kk: ArbInt;
-                  s: ArbFloat;
-          ppd, ppdx: ^arfloat1;
-
-begin
-  ppd:=@pd; ppdx:=@pdx;
-  for i:=m1 to m2 do
-    begin
-      ii:=(i-1)*rwidth; s:=ppd^[i];
-      for j:=k1 to k2 do ppdx^[ii+j]:=ppdx^[ii+j]*s;
-    end;
-  for i:=m1-1 downto 1 do
-    begin
-      k:=round(ppd^[i]); ii:=(i-1)*rwidth; kk:=(k-1)*rwidth;
-      if k <> i then
-        for j:=k1 to k2 do
-          begin
-            s:=ppdx^[ii+j]; ppdx^[ii+j]:=ppdx^[kk+j]; ppdx^[kk+j]:=s
-          end
-    end;
-  for i:=m2+1 to n do
-    begin
-      k:=round(ppd^[i]); ii:=(i-1)*rwidth; kk:=(k-1)*rwidth;
-      if k <> i then
-        for j:=k1 to k2 do
-          begin
-            s:=ppdx^[ii+j]; ppdx^[ii+j]:=ppdx^[kk+j]; ppdx^[kk+j]:=s
-          end
-    end
-end; {balback}
-
-procedure cdiv(xr, xi, yr, yi: ArbFloat; var zr, zi: ArbFloat);
-var h:ArbFloat;
-begin
-  if abs(yr)>abs(yi) then
-    begin
-      h:=yi/yr; yr:=h*yi+yr;
-      zr:=(xr+h*xi)/yr; zi:=(xi-h*xr)/yr;
-    end else
-    begin
-      h:=yr/yi; yi:=h*yr+yi;
-      zr:=(h*xr+xi)/yi; zi:=(h*xi-xr)/yi
-    end
-end; {cdiv}
-
-procedure hessvec(var h: ArbFloat; n, rwidthh: ArbInt; var lam: complex;
-                  var v: ArbFloat; rwidthv: ArbInt; var term: ArbInt);
-
-var                        iterate, stop, notlast, contin: boolean;
-           i, j, k, l, m, na, its, en, n1, n2, ii, kk, ll,
-                                   ik, i1, k0, k1, k2, mr: ArbInt;
-    meps, p, q, r, s, t, w, x, y, z, ra, sa, vr, vi, norm: ArbFloat;
-                                                   ph, pv: ^arfloat1;
-                                                   plam  : ^arcomp1;
-begin
-  ph:=@h; pv:=@v; plam:=@lam;
-  term:=1; en:=n; t:=0; meps:=macheps;
-  while (term=1) and (en>=1) do
-    begin
-      its:=0; na:=en-1; iterate:=true;
-      while iterate and (term=1) do
-        begin
-          l:=en; contin:=true;
-          while (l>=2) and contin do
-            begin
-              ll:=(l-1)*rwidthh+l;
-              if abs(ph^[ll-1])>meps*(abs(ph^[ll-rwidthh-1])+abs(ph^[ll]))
-              then l:=l-1 else contin:=false
-            end;
-          n1:=(na-1)*rwidthh; n2:=(en-1)*rwidthh; x:=ph^[n2+en];
-          if l=en then
-            begin
-              iterate:=false; plam^[en].Init(x+t, 0); ph^[n2+en]:=x+t;
-              en:=en-1
-            end else
-            if l=en-1 then
-              begin
-                iterate:=false; y:=ph^[n1+na]; w:=ph^[n2+na]*ph^[n1+en];
-                p:=(y-x)/2; q:=p*p+w; z:=sqrt(abs(q)); x:=x+t;
-                ph^[n2+en]:=x; ph^[n1+na]:=y+t;
-                if q>0 then
-                  begin
-                    if p<0 then z:=p-z else z:=p+z; plam^[na].Init(x+z, 0);
-                    s:=x-w/z; plam^[en].Init(s, 0);
-                    x:=ph^[n2+na]; r:=sqrt(x*x+z*z); p:=x/r; q:=z/r;
-                    for j:=na to n do
-                      begin
-                        z:=ph^[n1+j]; ph^[n1+j]:=q*z+p*ph^[n2+j];
-                        ph^[n2+j]:=q*ph^[n2+j]-p*z
-                      end;
-                    for i:=1 to en do
-                      begin
-                        ii:=(i-1)*rwidthh;
-                        z:=ph^[ii+na]; ph^[ii+na]:=q*z+p*ph^[ii+en];
-                        ph^[ii+en]:=q*ph^[ii+en]-p*z;
-                      end;
-                    for i:=1 to n do
-                      begin
-                        ii:=(i-1)*rwidthv;
-                        z:=pv^[ii+na]; pv^[ii+na]:=q*z+p*pv^[ii+en];
-                        pv^[ii+en]:=q*pv^[ii+en]-p*z;
-                      end
-                  end {q>0}
-                else
-                  begin
-                    plam^[na].Init(x+p, z); plam^[en].Init(x+p, -z)
-                  end;
-                en:=en-2;
-              end {l=en-1}
-            else
-              begin
-                y:=ph^[n1+na]; w:=ph^[n1+en]*ph^[n2+na];
-                if (its=10) or (its=20)
-                then
-                  begin
-                    t:=t+x;
-                    for i:=1 to en do
-                      ph^[(i-1)*rwidthh+i]:=ph^[(i-1)*rwidthh+i]-x;
-                    s:=abs(ph^[n2+na])+abs(ph^[n1+en-2]);
-                    y:=0.75*s; x:=y; w:=-0.4375*s*s;
-                  end;
-                m:=en-1; stop:=false;
-                repeat
-                  m:=m-1; mr:=m*rwidthh;
-                  z:=ph^[mr-rwidthh+m]; r:=x-z; s:=y-z;
-                  p:=(r*s-w)/ph^[mr+m]+ph^[mr-rwidthh+m+1];
-                  q:=ph^[mr+m+1]-z-r-s; r:=ph^[mr+rwidthh+m+1];
-                  s:=abs(p)+abs(q)+abs(r); p:=p/s; q:=q/s; r:=r/s;
-                  if m>l then
-                    stop:=abs(ph^[mr-rwidthh+m-1])*(abs(q)+abs(r))<=
-                          meps*abs(p)*(abs(ph^[mr-2*rwidthh+m-1])+
-                                          abs(z)+abs(ph^[mr+m+1]))
-                until stop or (m=l);
-                for i:=m+2 to en do ph^[(i-1)*rwidthh+i-2]:=0;
-                for i:=m+3 to en do ph^[(i-1)*rwidthh+i-3]:=0;
-                for k:=m to na do
-                  begin
-                    k0:=(k-1)*rwidthh; k1:=k0+rwidthh; k2:=k1+rwidthh;
-                    notlast:=k<na; contin:=true;
-                    if k>m then
-                      begin
-                        p:=ph^[k0+k-1]; q:=ph^[k1+k-1];
-                        if notlast then r:=ph^[k2+k-1] else r:=0;
-                        x:=abs(p)+abs(q)+abs(r);
-                        if x>0 then
-                          begin
-                            p:=p/x; q:=q/x; r:=r/x
-                          end else contin:=false
-                      end;
-                    if contin then
-                      begin
-                        s:=sqrt(p*p+q*q+r*r);
-                        if p<0 then s:=-s;
-                        if k>m then ph^[k0+k-1]:=-s*x else
-                        if l <> m then ph^[k0+k-1]:=-ph^[k0+k-1];
-                        p:=p+s; x:=p/s; y:=q/s; z:=r/s; q:=q/p; r:=r/p;
-                        for j:=k to n do
-                          begin
-                            p:=ph^[k0+j]+q*ph^[k1+j];
-                            if notlast then
-                              begin
-                                p:=p+r*ph^[k2+j];
-                                ph^[k2+j]:=ph^[k2+j]-p*z
-                              end;
-                            ph^[k1+j]:=ph^[k1+j]-p*y;
-                            ph^[k0+j]:=ph^[k0+j]-p*x
-                          end; {j}
-                        if k+3<en then j:=k+3 else j:=en;
-                        for i:=1 to j do
-                          begin
-                            ik:=(i-1)*rwidthh+k;
-                            p:=x*ph^[ik]+y*ph^[ik+1];
-                            if notlast then
-                              begin
-                                p:=p+z*ph^[ik+2]; ph^[ik+2]:=ph^[ik+2]-p*r
-                              end;
-                            ph^[ik+1]:=ph^[ik+1]-p*q; ph^[ik]:=ph^[ik]-p
-                          end;  {i}
-                        for i:=1 to n do
-                          begin
-                            ik:=(i-1)*rwidthv+k;
-                            p:=x*pv^[ik]+y*pv^[ik+1];
-                            if notlast then
-                              begin
-                                p:=p+z*pv^[ik+2]; pv^[ik+2]:=pv^[ik+2]-p*r
-                              end;
-                            pv^[ik+1]:=pv^[ik+1]-p*q; pv^[ik]:=pv^[ik]-p
-                          end  {i}
-                      end  {contin}
-                  end;  {k}
-                its:=its+1; if its >= 30 then term:=2
-              end  {ifl}
-        end  {iterate}
-    end;  {term=1}
-  if term=1 then
-    begin
-      norm:=0; k:=1;
-      for i:=1 to n do
-        begin
-          for j:=k to n do norm:=norm+abs(ph^[(i-1)*rwidthh+j]);
-          k:=i
-        end;
-      if norm=0 then
-        begin
-         { matrix is nulmatrix: eigenwaarden zijn alle 0 en aan de
-           eigenvectoren worden de eenheidsvectoren toegekend }
-          for i:=1 to n do plam^[i].Init(0, 0);
-          for i:=1 to n do
-            fillchar(pv^[(i-1)*rwidthv+1], n*sizeof(ArbFloat), 0);
-          for i:=1 to n do pv^[(i-1)*rwidthv+i]:=1;
-          exit
-        end; {norm=0}
-      for en:=n downto 1 do
-        begin
-          p:=plam^[en].re; q:=plam^[en].im; na:=en-1;
-          n1:=(na-1)*rwidthh; n2:=(en-1)*rwidthh;
-          if q=0 then
-            begin
-              m:=en; ph^[n2+en]:=1;
-              for i:=na downto 1 do
-                begin
-                  ii:=(i-1)*rwidthh; i1:=ii+rwidthh;
-                  w:=ph^[ii+i]-p; r:=ph^[ii+en];
-                  for j:=m to na do r:=r+ph^[ii+j]*ph^[(j-1)*rwidthh+en];
-                  if plam^[i].im < 0 then
-                    begin
-                      z:=w; s:=r
-                    end else
-                    begin
-                      m:=i; if plam^[i].im=0 then
-                      if w=0 then ph^[ii+en]:=-r/(meps*norm)
-                      else ph^[ii+en]:=-r/w else
-                        begin
-                          x:=ph^[ii+i+1]; y:=ph^[i1+i];
-                          q:=sqr(plam^[i].xreal-p)+sqr(plam^[i].imag);
-                          ph^[ii+en]:=(x*s-z*r)/q; t:=ph^[ii+en];
-                          if abs(x)>abs(z) then ph^[i1+en]:=(-r-w*t)/x
-                          else ph^[i1+en]:=(-s-y*t)/z;
-                        end  {plam^[i].imag > 0}
-                    end  {plam^[i].imag >= 0}
-                end  {i}
-            end {q=0}
-          else
-            if q<0 then
-              begin
-                m:=na;
-                if abs(ph^[n2+na]) > abs(ph^[n1+en]) then
-                  begin
-                    ph^[n1+na]:=-(ph^[n2+en]-p)/ph^[n2+na];
-                    ph^[n1+en]:=-q/ph^[n2+na];
-                  end else
-                  cdiv(-ph^[n1+en], 0, ph^[n1+na]-p, q,
-                        ph^[n1+na], ph^[n1+en]);
-                ph^[n2+na]:=1; ph^[n2+en]:=0;
-                for i:=na-1 downto 1 do
-                  begin
-                    ii:=(i-1)*rwidthh; i1:=ii+rwidthh;
-                    w:=ph^[ii+i]-p; ra:=ph^[ii+en]; sa:=0;
-                    for j:=m to na do
-                      begin
-                        ra:=ra+ph^[ii+j]*ph^[(j-1)*rwidthh+na];
-                        sa:=sa+ph^[ii+j]*ph^[(j-1)*rwidthh+en]
-                      end;
-                    if plam^[i].imag < 0 then
-                      begin
-                        z:=w; r:=ra; s:=sa
-                      end else
-                      begin
-                        m:=i;
-                        if plam^[i].imag=0
-                        then cdiv(-ra, -sa, w, q, ph^[ii+na], ph^[ii+en])
-                        else
-                          begin
-                            x:=ph^[ii+i+1]; y:=ph^[i1+i];
-                            vr:=sqr(plam^[i].xreal-p)+sqr(plam^[i].imag)-q*q;
-                            vi:=(plam^[i].xreal-p)*q*2;
-                            if (vr=0) and (vi=0)
-                            then
-                               vr:=meps*norm*(abs(w)+abs(q)+abs(x)+
-                                                   abs(y)+abs(z));
-                            cdiv(x*r-z*ra+q*sa, x*s-z*sa-q*ra, vr, vi,
-                                 ph^[ii+na], ph^[ii+en]);
-                            if abs(x)>abs(z)+abs(q)
-                            then
-                              begin
-                                ph^[i1+na]:=(-ra-w*ph^[ii+na]+q*ph^[ii+en])/x;
-                                ph^[i1+en]:=(-sa-w*ph^[ii+en]-q*ph^[ii+na])/x
-                              end
-                            else
-                              cdiv(-r-y*ph^[ii+na], -s-y*ph^[ii+en],
-                                   z, q, ph^[i1+na], ph^[i1+en])
-                          end  {plam^[i].imag > 0}
-                      end {plam^[i].imag >= 0}
-                  end  {i}
-              end
-        end  {backsubst};
-      for j:=n downto 1 do
-        begin
-          m:=j; l:=j-1;
-          if plam^[j].imag < 0 then
-            begin
-              for i:=1 to n do
-                begin
-                  ii:=(i-1)*rwidthv; y:=0; z:=0;
-                  for k:=1 to m do
-                    begin
-                      kk:=(k-1)*rwidthh;
-                      y:=y+pv^[ii+k]*ph^[kk+l];
-                      z:=z+pv^[ii+k]*ph^[kk+j]
-                    end;
-                  pv^[ii+l]:=y; pv^[ii+j]:=z
-                end  {i}
-            end else
-            if plam^[j].imag=0 then
-              for i:=1 to n do
-                begin
-                  z:=0;
-                  ii:=(i-1)*rwidthv;
-                  for k:=1 to m do z:=z+pv^[ii+k]*ph^[(k-1)*rwidthh+j];
-                  pv^[ii+j]:=z;
-                end  {i}
-        end {j}
-    end  {term=1}
-end;  {hessvec}
-
-procedure normeer(var lam: complex; n: ArbInt; var v: ArbFloat;
-                  rwidthv: ArbInt);
-
-var              i, j, k, ii, kk: ArbInt;
-               max, s, t, vr, vi: ArbFloat;
-                              pv: ^arfloat1;
-                            plam: ^arcomp1;
-begin
-  plam:=@lam; pv:=@v; j:=1;
-  while j<=n do
-    if plam^[j].imag=0 then
-      begin
-        s:=0; for i:=1 to n do s:=s+sqr(pv^[(i-1)*rwidthv+j]); s:=sqrt(s);
-        for i:=1 to n do pv^[(i-1)*rwidthv+j]:=pv^[(i-1)*rwidthv+j]/s;
-        j:=j+1
-      end else
-      begin
-        max:=0; s:=0;
-        for i:=1 to n do
-          begin
-            ii:=(i-1)*rwidthv;
-            t:=sqr(pv^[ii+j])+sqr(pv^[ii+j+1]); s:=s+t;
-            if t>max then
-              begin
-                max:=t; k:=i
-              end
-          end;
-        kk:=(k-1)*rwidthv;
-        s:=sqrt(max/s); t:=pv^[kk+j+1]/s; s:=pv^[kk+j]/s;
-        for i:=1 to n do
-          begin
-            ii:=(i-1)*rwidthv;
-            vr:=pv^[ii+j]; vi:=pv^[ii+j+1];
-            cdiv(vr, vi, s, t, pv^[ii+j], pv^[ii+j+1]);
-          end;
-        pv^[kk+j+1]:=0; j:=j+2;
-      end
-end; {normeer}
-
-procedure transx(var v: ArbFloat; n, rwidthv: ArbInt; var lam, x: complex;
-                 rwidthx: ArbInt);
-
-var  i, j, ix, iv : ArbInt;
-               pv : ^arfloat1;
-         plam, px : ^arcomp1;
-begin
-  pv:=@v; plam:=@lam; px:=@x;
-  for i:=1 to n do
-    if plam^[i].imag > 0 then
-      for j:=1 to n do
-        begin
-          iv:=(j-1)*rwidthv+i; ix:=(j-1)*rwidthx+i;
-          px^[ix].xreal:=pv^[iv]; px^[ix].imag:=pv^[iv+1]
-        end else
-    if plam^[i].imag < 0 then
-      for j:=1 to n do
-        begin
-          iv:=(j-1)*rwidthv+i; ix:=(j-1)*rwidthx+i;
-          px^[ix].xreal:=pv^[iv-1]; px^[ix].imag:=-pv^[iv]
-        end else
-      for j:=1 to n do
-        begin
-          iv:=(j-1)*rwidthv+i; ix:=(j-1)*rwidthx+i;
-          px^[ix].xreal:=pv^[iv]; px^[ix].imag:=0
-        end
-end; {transx}
-
-procedure reduc1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
-                 rwidthb: ArbInt; var term: ArbInt);
-
-var  i, j, k, ia, ja, ib, jb : ArbInt;
-                        x, y : ArbFloat;
-                      pa, pb : ^arfloat1;
-begin
-  pa:=@a; pb:=@b;
-  term:=1; i:=0;
-  while (i<n) and (term=1) do
-    begin
-      i:=i+1; j:=i-1; jb:=(j-1)*rwidthb; ib:=(i-1)*rwidthb;
-      while (j<n) and (term=1) do
-        begin
-          j:=j+1; jb:=jb+rwidthb; x:=pb^[jb+i];
-          for k:=1 to i-1 do x:=x-pb^[ib+k]*pb^[jb+k];
-            if i=j then
-              begin
-                if x<=0 then term:=2 else
-                  begin
-                    y:=sqrt(x); pb^[ib+i]:=y
-                  end
-              end else pb^[jb+i]:=x/y
-        end  {j}
-    end; {i}
-  if term=1 then
-    begin
-      for i:=1 to n do
-        begin
-          ib:=(i-1)*rwidthb; y:=pb^[ib+i];
-          for j:=i to n do
-            begin
-              ja:=(j-1)*rwidtha; x:=pa^[ja+i];
-              for k:=i-1 downto 1 do x:=x-pb^[ib+k]*pa^[ja+k];
-                pa^[ja+i]:=x/y;
-            end {j}
-        end; {i}
-      for j:=1 to n do
-        begin
-          ja:=(j-1)*rwidtha;
-          for i:=j to n do
-            begin
-              ia:=(i-1)*rwidtha; ib:=(i-1)*rwidthb; x:=pa^[ia+j];
-              for k:=i-1 downto j do x:=x-pa^[(k-1)*rwidtha+j]*pb^[ib+k];
-              for k:=j-1 downto 1 do x:=x-pa^[ja+k]*pb^[ib+k];
-              pa^[ia+j]:=x/pb^[ib+i]
-            end {i}
-        end {j}
-    end {term=1};
-end; {reduc1}
-
-procedure rebaka(var l: ArbFloat; n, rwidthl, k1, k2: ArbInt; var x: ArbFloat;
-                 rwidthx: ArbInt; var term: ArbInt);
-
-var         pl, px : ^arfloat1;
-   i, j, k, il, ix : ArbInt;
-                y : ArbFloat;
-begin
-  pl:=@l; px:=@x; term:=1; il:=1;
-  for i:=1 to n do
-    begin
-      if pl^[il]=0 then
-        begin
-          term:=2; exit
-        end;
-      il:=il+rwidthl+1
-    end; {i}
-  for j:=1 to k2-k1+1 do
-    for i:=n downto 1 do
-      begin
-        il:=(i-1)*rwidthl; ix:=(i-1)*rwidthx; y:=px^[ix+j];
-        for k:=i+1 to n do y:=y-pl^[(k-1)*rwidthl+i]*px^[(k-1)*rwidthx+j];
-        px^[ix+j]:=y/pl^[il+i]
-      end
-end; {rebaka}
-
-end.
-
-
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:43  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:14  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:41  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/int.pas

@@ -1,1080 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Integration. This routine is fit for smooth "integrand" so no singularities,
-    sharp edges, or quickly oscillating behaviour.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-Unit int;
-{$I DIRECT.INC}
-
-interface
-
-uses typ;
-
-Var 
-    limit    : ArbInt;
-    epsrel   : ArbFloat;
-
-{calc int(x,a,b,f(x)) for a function with a nice behaviour in the
-interval [A,B]}
-
-Procedure int1fr(f: rfunc1r; a, b, ae: ArbFloat; Var integral, err: ArbFloat;
-                 Var term: ArbInt);
-
-implementation
-
-Function amin1(x, y: ArbFloat): ArbFloat;
-Begin
-    If x<y Then amin1 := x
- Else amin1 := y
-End;
-
-Function amax1(x, y: ArbFloat): ArbFloat;
-Begin
-    If x>y Then amax1 := x
- Else amax1 := y
-End;
-
-Procedure qk21(f: rfunc1r; a, b: ArbFloat;
-               Var result, abserr, resabs, resasc: ArbFloat);
-
-Const 
-
- xgk: array[1..11] Of ArbFloat = 
-                                ( 0.9956571630258081, 0.9739065285171717,
-                                  0.9301574913557082, 0.8650633666889845,
-                                  0.7808177265864169, 0.6794095682990244,
-                                  0.5627571346686047, 0.4333953941292472,
-                                  0.2943928627014602, 0.1488743389816312, 0);
-
- wgk: array[1..11] Of ArbFloat = 
-                                ( 0.1169463886737187e-1, 0.3255816230796473e-1,
-                                  0.5475589657435200e-1, 0.7503967481091995e-1,
-                                  0.9312545458369761e-1, 0.1093871588022976,
-                                  0.1234919762620659,    0.1347092173114733,
-                                  0.1427759385770601,    0.1477391049013385,
-                                  0.1494455540029169);
-
- wg: array[1..5] Of ArbFloat = 
-                              ( 0.6667134430868814e-1, 0.1494513491505806,
-                                0.2190863625159820,    0.2692667193099964,
-                                0.2955242247147529);
-
-Var  absc, centr, dhlgth, fc, fsum, fval1, fval2,
-     hlgth, resg, resk, reskh: ArbFloat;
-     j, jtw, jtwm1: ArbInt;
-          fv1, fv2: ^arfloat1;
-Begin
-   getmem(fv1, 10*sizeof(ArbFloat));
- getmem(fv2, 10*sizeof(ArbFloat));
-   centr := (a+b)/2;
- hlgth := (b-a)/2;
- dhlgth := abs(hlgth);
- resg := 0;
-   fc := f(centr);
- resk := wgk[11]*fc;
- resabs := abs(resk);
-   For j:=1 To 5 Do
-    Begin
-       jtw := 2*j;
-     absc := hlgth*xgk[jtw];
-       fval1 := f(centr-absc);
-     fval2 := f(centr+absc);
-       fv1^[jtw] := fval1;
-     fv2^[jtw] := fval2;
-     fsum := fval1+fval2;
-       resg := resg+wg[j]*fsum;
-     resk := resk+wgk[jtw]*fsum;
-       resabs := resabs+wgk[jtw]*(abs(fval1)+abs(fval2))
-    End;
-   For j:=1 To 5 Do
-    Begin
-       jtwm1 := 2*j-1;
-     absc := hlgth*xgk[jtwm1];
-       fval1 := f(centr-absc);
-     fval2 := f(centr+absc);
-       fv1^[jtwm1] := fval1;
-     fv2^[jtwm1] := fval2;
-     fsum := fval1+fval2;
-       resk := resk+wgk[jtwm1]*fsum;
-       resabs := resabs+wgk[jtwm1]*(abs(fval1)+abs(fval2))
-    End;
-   reskh := resk/2;
- resasc := wgk[11]*abs(fc-reskh);
-   For j:=1 To 10 Do
-     resasc := resasc+wgk[j]*(abs(fv1^[j]-reskh)+abs(fv2^[j]-reskh));
-   result := resk*hlgth;
- resabs := resabs*dhlgth;
- resasc := resasc*dhlgth;
-   abserr := abs((resk-resg)*hlgth);
-   If (resasc <> 0) And (abserr <> 0)
-    Then abserr := resasc*amin1(1,exp(1.5*ln(200*abserr/resasc)));
-   If resabs > midget/(50*macheps)
-    Then abserr := amax1((50*macheps)*resabs, abserr);
-   freemem(fv1, 10*sizeof(ArbFloat));
- freemem(fv2, 10*sizeof(ArbFloat));
-End;
-
-Procedure qpsrt(limit: ArbInt;
-                Var last, maxerr: ArbInt;
-                Var ermax, elist1: ArbFloat;
-                Var iord1, nrmax: ArbInt);
-
-Var errmax, errmin: ArbFloat;
-    i, ibeg, ido, isucc,
-    j, jbnd, jupbn, k : ArbInt;
-    continue : boolean;
-    elist : arfloat1 absolute elist1;
-    iord  : arint1 absolute iord1;
-Begin
-      If (last<=2)
-       Then
-       Begin
-          iord[1] := 1;
-          iord[2] := 2;
-          maxerr := iord[nrmax];
-          ermax := elist[maxerr];
-          exit
-       End;
-
-      errmax := elist[maxerr];
-      ido := nrmax-1;
-      i := 0;
-      If ido>0 Then
-       Repeat
-          Inc(i);
-          isucc := iord[nrmax-1];
-          If errmax>elist[isucc]
-           Then
-           Begin
-               iord[nrmax] := isucc;
-               nrmax := nrmax-1
-           End
-        Else i := ido
-       Until (i=ido);
-
-      jupbn := last;
-      If (last>(limit Div 2+2)) Then jupbn := limit+3-last;
-      errmin := elist[last];
-      jbnd := jupbn-1;
-      ibeg := nrmax+1;
-
-      If (ibeg>jbnd)
-       Then
-       Begin
-         iord[jbnd] := maxerr;
-         iord[jupbn] := last;
-         maxerr := iord[nrmax];
-         ermax := elist[maxerr];
-         exit
-       End;
-
-      i := ibeg-1;
-      continue := true;
-      while (i<jbnd) and continue Do
-      Begin
-        Inc(i);
-        isucc := iord[i];
-        If (errmax<elist[isucc])
-         Then iord[i-1] := isucc
-        Else continue := false
-      End;
-      If continue
-       Then
-       Begin
-          iord[jbnd] := maxerr;
-          iord[jupbn] := last
-       End
- Else
-      Begin
-          iord[i-1] := maxerr;
-          k := jbnd;
-          continue := true;
-          j := i-1;
-          while (j<jbnd) and continue Do
-          Begin
-             Inc(j);
-             isucc := iord[k];
-             If errmin<elist[isucc]
-              Then continue := false
-             Else
-              Begin
-                 iord[k+1] := isucc;
-                 Dec(k)
-              End
-          End;
-          If continue Then iord[i] := last
-                      Else iord[k+1] := last
-      End;
-
-      maxerr := iord[nrmax];
-      ermax := elist[maxerr]
-
-End;
-
-Type 
-     stock = array[1..52] Of ArbFloat;
-     hulpar = array[1..3] Of ArbFloat;
-
-Procedure qelg(Var n: ArbInt;
-               Var epstab: stock;
-               Var result, abserr: ArbFloat;
-               Var res3la: hulpar;
-               Var nres: ArbInt);
-
-Var 
-     delta1, delta2, delta3,
-     epsinf, error, err1, err2, err3,
-     e0, e1, e2, e3, e0abs, e1abs, e2abs, e3abs,
-     res, ss, tol1, tol2, tol3: ArbFloat;
-     i, ib, ib2, k1, k2, k3,
-     limexp, num, newelm:  ArbInt;
-     continue: boolean;
-Begin
-      Inc(nres);
-      abserr := giant;
-      result := epstab[n];
-
-      If (n<3) Then exit;
-
-      limexp := 50;
-      epstab[n+2] := epstab[n];
-      epstab[n] := giant;
-      num := n;
-      k1 := n;
-      continue := true;
-      i := 1;
-      newelm := (n-1) Div 2;
-      while (i<=newelm) and continue Do
-      Begin
-        k2 := k1-1;
-        k3 := k1-2;
-        res := epstab[k1+2];
-        e0 := epstab[k3];
-        e1 := epstab[k2];
-        e2 := res;
-        e0abs := abs(e0);
-        e1abs := abs(e1);
-        e2abs := abs(e2);
-        delta2 := e2-e1;
-        err2 := abs(delta2);
-
-        If e1abs>e2abs
-         Then tol2 := e1abs*macheps
-        Else tol2 := e2abs*macheps;
-
-        delta3 := e1-e0;
-        err3 := abs(delta3);
-        If e1abs>e0abs
-         Then tol3 := e1abs*macheps
-        Else tol3 := e0abs*macheps;
-
-        If (err2<=tol2) And (err3<=tol3)
-         Then
-         Begin
-           result := res;
-           abserr := err2+err3;
-           If abserr<5*macheps*abs(result)
-            Then abserr := 5*macheps*abs(result);
-           exit
-         End;
-
-        e3 := epstab[k1];
-        epstab[k1] := e1;
-        delta1 := e1-e3;
-        err1 := abs(delta1);
-        e3abs := abs(e3);
-
-        If e1abs<e3abs
-         Then tol1 := e3abs*macheps
-        Else tol1 := e1abs*macheps;
-
-        continue := false;
-
-        If (err1<=tol1) Or (err2<=tol2) Or (err3<=tol3)
-         Then n := 2*i-1
-        Else
-         Begin
-           ss := 1/delta1 + 1/delta2 - 1/delta3;
-           epsinf := abs(ss*e1);
-           If (epsinf>1e-4)
-            Then
-            Begin
-              continue := true;
-              res := e1+1/ss;
-              epstab[k1] := res;
-              k1 := k1-2;
-              error := err2+abs(res-e2)+err3;
-              If (error<=abserr)
-               Then
-               Begin
-                 abserr := error;
-                 result := res
-               End
-            End
-          Else n := 2*i-1
-         End;
-        Inc(i)
-
-      End;
-
-      If n=limexp Then n := 2*(limexp Div 2)-1;
-
-      If Odd(Num) Then ib := 1
- Else ib := 2;
-
-      For i:=1 To newelm+1 Do
-       Begin
-         ib2 := ib+2;
-         epstab[ib] := epstab[ib2];
-         ib := ib2
-       End;
-
-      Move(epstab[num-n+1], epstab[1], n*SizeOf(ArbFloat));
-
-      If (nres<4)
-       Then
-       Begin
-         res3la[nres] := result;
-         abserr := giant
-       End
- Else
-      Begin
-         abserr := abs(result-res3la[3]) +
-                   abs(result-res3la[2]) +
-                   abs(result-res3la[1]);
-         res3la[1] := res3la[2];
-         res3la[2] := res3la[3];
-         res3la[3] := result;
-         If abserr<5*macheps*abs(result)
-          Then abserr := 5*macheps*abs(result)
-      End
-End;
-
-Procedure qagse(f: rfunc1r; a, b, epsabs, epsrel: ArbFloat;
-                limit: ArbInt; Var result, abserr: ArbFloat;
-                Var neval, ier, last: ArbInt);
-
-Var abseps, area, area1, area12, area2, a1, a2, b1, b2, correc, defabs,
-    defab1, defab2, dres, erlarg, erlast, errbnd, errmax,
-    error1, error2, erro12, errsum, ertest, resabs, reseps, small: ArbFloat;
-    id, ierro, iroff1, iroff2, iroff3, jupbnd, k, ksgn,
-    ktmin, maxerr, nres, nrmax, numrl2, sr, lsr: ArbInt;
-    extrap, noext, go_on, jump, smallers, p0, p1, p2, p3: boolean;
-    alist, blist, elist, rlist: ^arfloat1;
-    res3la: hulpar;
-    rlist2: stock;
-    iord: ^arint1;
-Begin
-  sr := sizeof(ArbFloat);
- lsr := limit*sr;
-  getmem(alist, lsr);
-  getmem(blist, lsr);
-  getmem(elist, lsr);
-  getmem(iord, limit*sizeof(ArbInt));
-  getmem(rlist, lsr);
-  ier := 0;
- neval := 0;
- last := 0;
- result := 0;
- abserr := 0;
-  alist^[1] := a;
- blist^[1] := b;
- rlist^[1] := 0;
- elist^[1] := 0;
-  If (epsabs <= 0) And (epsrel < amax1(0.5e+02*macheps, 0.5e-14)) Then
-   Begin
-      ier := 6;
-      freemem(rlist, lsr);
-      freemem(iord, limit*sizeof(ArbInt));
-      freemem(elist, lsr);
-      freemem(blist, lsr);
-      freemem(alist, lsr);
-      exit
-   End;
-  ierro := 0;
-  qk21(f, a, b, result, abserr, defabs, resabs);
- dres := abs(result);
-  errbnd := amax1(epsabs, epsrel*dres);
-  last := 1;
- rlist^[1] := result;
- elist^[1] := abserr;
-  iord^[1] := 1;
-  If (abserr <= 100*macheps*defabs) And (abserr>errbnd) Then ier := 2;
-  If limit=1 Then ier := 1;
-  If (ier <> 0) Or ((abserr <= errbnd) And (abserr <> resabs)) Or (abserr=0)
-   Then
-   Begin
-      neval := 21;
-      freemem(rlist, lsr);
-      freemem(iord, limit*sizeof(ArbInt));
-      freemem(elist, lsr);
-      freemem(blist, lsr);
-      freemem(alist, lsr);
-      exit
-   End;
-  rlist2[1] := result;
- errmax := abserr;
- maxerr := 1;
- area := result;
-  errsum := abserr;
- abserr := giant;
- nrmax := 1;
- nres := 0;
- numrl2 := 2;
- ktmin := 0;
-  extrap := false;
- noext := false;
- iroff1 := 0;
- iroff2 := 0;
- iroff3 := 0;
- ksgn := -1;
-  If dres >= (1-50*macheps)*defabs Then ksgn := 1;
-  go_on := limit > 1;
- smallers := false;
-  while go_on Do
-    Begin
-      inc(last);
-     a1 := alist^[maxerr];
-      b1 := (alist^[maxerr]+blist^[maxerr])/2;
-     a2 := b1;
-     b2 := blist^[maxerr];
-      erlast := errmax;
-      qk21(f, a1, b1, area1, error1, resabs, defab1);
-      qk21(f, a2, b2, area2, error2, resabs, defab2);
-      area12 := area1+area2;
-     erro12 := error1+error2;
-      errsum := errsum+erro12-errmax;
-     area := area+area12-rlist^[maxerr];
-      If (defab1 <> error1) And (defab2 <> error2) Then
-        Begin
-          If (abs(rlist^[maxerr]-area12) <= 1e-5*abs(area12))
-              And (erro12 >= 0.99*errmax) Then
-           Begin
-            If extrap Then inc(iroff2)
-            Else inc(iroff1)
-           End;
-          If (last > 10) And (erro12 > errmax) Then inc(iroff3)
-        End;
-      rlist^[maxerr] := area1;
-     rlist^[last] := area2;
-      errbnd := amax1(epsabs, epsrel*abs(area));
-      If (iroff1+iroff2 >= 10) Or (iroff3>=20) Then ier := 2;
-      If iroff2>=5 Then ierro := 3;
-     If last=limit Then ier := 1;
-      If amax1(abs(a1),abs(b2)) <= (1+100*macheps)*(abs(a2)+1000*midget)
-       Then ier := 4;
-      If error2 <= error1 Then
-        Begin
-          alist^[last] := a2;
-         blist^[maxerr] := b1;
-         blist^[last] := b2;
-          elist^[maxerr] := error1;
-         elist^[last] := error2
-        End
-     Else
-        Begin
-          alist^[maxerr] := a2;
-         alist^[last] := a1;
-         blist^[last] := b1;
-          rlist^[maxerr] := area2;
-         rlist^[last] := area1;
-          elist^[maxerr] := error2;
-         elist^[last] := error1
-        End;
-      qpsrt(limit, last, maxerr, errmax, elist^[1], iord^[1], nrmax);
-      If errsum <= errbnd Then
-        Begin
-          smallers := true;
-         go_on := false
-        End
-     Else
-        Begin
-          If ier <> 0 Then go_on := false
-         Else
-            Begin
-              If (last=2) Or (Not noext) Then
-                Begin
-                  If last <> 2 Then
-                    Begin
-                      erlarg := erlarg-erlast;
-                      If abs(b1-a1) > small Then erlarg := erlarg+erro12;
-                      If extrap Or
-                         (abs(blist^[maxerr]-alist^[maxerr]) <= small) Then
-                        Begin
-                          If Not extrap Then nrmax := 2;
-                         extrap := true;
-                          jump := false;
-                          If (ierro <> 3) And (erlarg>=ertest) Then
-                            Begin
-                              id := nrmax;
-                             jupbnd := last;
-                              If last > 2+limit/2 Then jupbnd := limit+3-last;
-                              k := id;
-                              while (k <= jupbnd) and (Not jump) Do
-                                Begin
-                                  maxerr := iord^[nrmax];
-                                  errmax := elist^[maxerr];
-                                  If abs(blist^[maxerr]-alist^[maxerr]) > small
-                                   Then jump := true
-                                  Else
-                                    Begin
-                                      nrmax := nrmax+1;
-                                     k := k+1
-                                    End
-                                End;
-                            End; {(ierro <> 3) and (erlarg>=ertest)}
-                          If Not jump Then
-                            Begin
-                              numrl2 := numrl2+1;
-                             rlist2[numrl2] := area;
-                              qelg(numrl2, rlist2, reseps, abseps,
-                                   res3la, nres);
-                              ktmin := ktmin+1;
-                              If (ktmin > 5) And (abserr < 1e-3*errsum)
-                               Then ier := 5;
-                              If abseps < abserr Then
-                                Begin
-                                  ktmin := 0;
-                                 abserr := abseps;
-                                 result := reseps;
-                                  correc := erlarg;
-                                  ertest := amax1(epsabs,epsrel*abs(reseps));
-                                  If abserr <= ertest Then go_on := false
-                                End;
-                              If go_on Then
-                                Begin
-                                  If numrl2=1 Then noext := true;
-                                  If ier=5 Then go_on := false
-                                 Else
-                                    Begin
-                                      maxerr := iord^[1];
-                                     errmax := elist^[maxerr];
-                                      nrmax := 1;
-                                     extrap := false;
-                                     small := small/2;
-                                      erlarg := errsum
-                                    End; {ier <> 5}
-                                End; {go_on}
-                            End; {not jump}
-                        End;  { abs(blist^[maxerr]-alist^[maxerr]) <= small }
-                    End
-                 Else {last=2}
-                      Begin
-                        small := abs(b-a)*0.375;
-                       erlarg := errsum;
-                        ertest := errbnd;
-                       rlist2[2] := area
-                      End
-                End; {last=2 or not noext}
-            End; {ier <> 0}
-        End; {errsum <= errbnd}
-      If go_on Then go_on := last < limit
-    End; {while go_on}
-  p0 := false;
- p1 := false;
- p2 := false;
- p3 := false;
-  If (abserr=giant) Or smallers Then p0 := true
- Else
-  If ier+ierro=0 Then p1 := true;
-  If Not (p0 Or p1) Then
-    Begin
-      If ierro=3 Then abserr := abserr+correc;
-      If ier=0 Then ier := 3;
-      If (result <> 0) And (area <> 0) Then p2 := true
-     Else
-      If abserr > errsum Then p0 := true
-     Else
-      If area=0 Then p3 := true
-     Else p1 := true
-    End;
-  If p2 Then
-    Begin
-      If abserr/abs(result) > errsum/abs(area) Then p0 := true
-     Else p1 := true
-    End;
-  If p1 Then
-    Begin
-      If (ksgn=-1) And (amax1(abs(result),abs(area)) <= defabs*0.01)
-       Then p3 := true
-     Else
-      If (0.01 > result/area) Or (result/area > 100) Or (errsum>abs(area))
-       Then ier := 6;
-      p3 := true
-    End;
-  If p0 Then
-    Begin
-      result := 0;
-      For k:=1 To last Do
-       result := result+rlist^[k]
-    End;
-  If Not p3 Then abserr := errsum;
-  If ier>2 Then ier := ier-1;
-  neval := 42*last-21;
-  freemem(alist, lsr);
- freemem(blist, lsr);
- freemem(elist, lsr);
-  freemem(rlist, lsr);
- freemem(iord, limit*sizeof(ArbInt));
-End;
-
-
-{    single-precision machine constants
-   r1mach(1) = b**(emin-1), the midget positive magnitude..
-   r1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude.
-   r1mach(3) = b**(-t), the midget relative spacing.
-   r1mach(4) = b**(1-t), the largest relative spacing.
-   r1mach(5) = log10(b)
-}
-
-Procedure qk15i(f: rfunc1r; boun: ArbFloat;
-                inf: ArbInt;
-                a, b: ArbFloat;
-                Var result, abserr, resabs, resasc: ArbFloat);
-
-Const  xgk : array[1..8] Of ArbFloat = (
-                                        0.9914553711208126, 0.9491079123427585,
-                                        0.8648644233597691, 0.7415311855993944,
-                                        0.5860872354676911, 0.4058451513773972,
-                                        0.2077849550078985, 0.0000000000000000);
-      wgk : array[1..8] Of ArbFloat = (
-                                       0.02293532201052922,0.06309209262997855,
-                                       0.1047900103222502, 0.1406532597155259,
-                                       0.1690047266392679, 0.1903505780647854,
-                                       0.2044329400752989, 0.2094821410847278);
-      wg : array[1..8] Of ArbFloat = (
-                                      0, 0.1294849661688697,
-                                      0, 0.2797053914892767,
-                                      0, 0.3818300505051189,
-                                      0, 0.4179591836734694);
-
-Var  absc, absc1, absc2, centr,
-     dinf, fc, fsum, fval1, fval2,
-     hlgth, resg, resk, reskh,
-     tabsc1, tabsc2: ArbFloat;
-
-     fv1, fv2: array[1..7] Of ArbFloat;
-
-     j, min0: ArbInt;
-Begin
-      If inf<1 Then dinf := inf
- Else dinf := 1;
-      centr := 0.5*(a+b);
-      hlgth := 0.5*(b-a);
-      tabsc1 := boun+dinf*(1-centr)/centr;
-      fval1 := f(tabsc1);
-      If (inf=2) Then fval1 := fval1+f(-tabsc1);
-      fc := (fval1/centr)/centr;
-      resg := wg[8]*fc;
-      resk := wgk[8]*fc;
-      resabs := abs(resk);
-      For j:=1 To 7 Do
-       Begin
-        absc := hlgth*xgk[j];
-        absc1 := centr-absc;
-        absc2 := centr+absc;
-        tabsc1 := boun+dinf*(1-absc1)/absc1;
-        tabsc2 := boun+dinf*(1-absc2)/absc2;
-        fval1 := f(tabsc1);
-        fval2 := f(tabsc2);
-        If (inf=2) Then fval1 := fval1+f(-tabsc1);
-        If (inf=2) Then fval2 := fval2+f(-tabsc2);
-        fval1 := (fval1/absc1)/absc1;
-        fval2 := (fval2/absc2)/absc2;
-        fv1[j] := fval1;
-        fv2[j] := fval2;
-        fsum := fval1+fval2;
-        resg := resg+wg[j]*fsum;
-        resk := resk+wgk[j]*fsum;
-        resabs := resabs+wgk[j]*(abs(fval1)+abs(fval2))
-       End;
-
-      reskh := resk*0.5;
-      resasc := wgk[8]*abs(fc-reskh);
-
-      For j:=1 To 7 
-       Do
-       resasc := resasc+wgk[j]*(abs(fv1[j]-reskh)+abs(fv2[j]-reskh));
-
-      result := resk*hlgth;
-      resasc := resasc*hlgth;
-      resabs := resabs*hlgth;
-      abserr := abs((resk-resg)*hlgth);
-
-      If (resasc<>0) And (abserr<>0)
-       Then
-       Begin
-           reskh := 200*abserr/resasc;
-           If reskh<1
-            Then abserr := resasc*reskh*sqrt(reskh)
-           Else abserr := resasc
-       End;
-
-      If (resabs>midget/(50*macheps))
-       Then
-       Begin
-           reskh := macheps*50*resabs;
-           If abserr<reskh Then abserr := reskh
-       End
-End;
-
-
-
-Procedure qagie(f: rfunc1r;
-                bound: ArbFloat;
-                inf: ArbInt;
-                epsabs, epsrel: ArbFloat;
-                Var result, abserr: ArbFloat;
-                Var ier: ArbInt);
-
-{ procedure qagie is vertaald vanuit de PD-quadpack-Fortran-routine QAGIE
-  naar Turbo Pascal, waarbij de volgende parameters uit de parameterlijst
-  verdwenen zijn:
-      limit , zoiets als 'maximale recursie diepte' vervangen door globale
-              variabele limit, initieel op 500 gezet
-      last  , actuele 'recursie diepte'
-      workarrays: alist, blist, rlist, elist en iord ,
-                  vervangen door dynamische locale arrays
-      neval , het aantal functie-evaluaties
-}
-
-Var  abseps, area, area1, area12, area2,
-     a1, a2, b1,b2, correc,
-     defabs, defab1, defab2, dres,
-     erlarg, erlast, errbnd, h,
-     errmax, error1, error2, erro12, errsum, ertest, resabs,
-     reseps, small: ArbFloat;
-     res3la : hulpar;
-
-     rlist, alist, blist, elist: ^arfloat1;
-     iord: ^arint1;
-     rlist2 : stock;
-     id, ierro, iroff1, iroff2, iroff3, jupbnd,
-     k, ksgn, ktmin, last, maxerr, nres, nrmax, numrl2: ArbInt;
-     continue, break, extrap, noext : boolean;
-Begin
-      ier := 6;
-      h := 50*macheps;
-      If h<0.5e-14 Then h := 0.5e-14;
-      If (epsabs<=0) And (epsrel<h) Then exit;
-
-      If (inf=2) Then bound := 0;
-
-      qk15i(f, bound, inf, 0, 1, result, abserr, defabs, resabs);
-
-      dres := abs(result);
-
-      errbnd := epsrel*dres;
-      If epsabs>errbnd Then errbnd := epsabs;
-
-      ier := 2;
-      If (abserr<=100*macheps*defabs) And (abserr>errbnd) Then exit;
-      ier := 0;
-      If ((abserr<=errbnd) And (abserr<>resabs)) Or (abserr=0) Then exit;
-
-      GetMem(rlist, limit*SizeOf(ArbFloat));
-      GetMem(alist, limit*SizeOf(ArbFloat));
-      GetMem(blist, limit*SizeOf(ArbFloat));
-      GetMem(elist, limit*SizeOf(ArbFloat));
-      GetMem(iord, limit*SizeOf(ArbInt));
-
-      alist^[1] := 0;
-      blist^[1] := 1;
-      rlist^[1] := result;
-      elist^[1] := abserr;
-      iord^[1]  := 1;
-      rlist2[1] := result;
-      errmax    := abserr;
-      maxerr    := 1;
-      area      := result;
-      errsum    := abserr;
-      abserr    := giant;
-      nrmax     := 1;
-      nres      := 0;
-      ktmin     := 0;
-      numrl2    := 2;
-      extrap    := false;
-      noext     := false;
-      ierro     := 0;
-      iroff1    := 0;
-      iroff2    := 0;
-      iroff3    := 0;
-
-      If dres>=(1-50*macheps)*defabs Then ksgn := 1
- Else ksgn := -1;
-
-      last := 1;
-      continue := true;
-      while (last<limit) and (ier=0) and continue Do
-      Begin
-        Inc(last);
-        a1 := alist^[maxerr];
-        b1 := 0.5*(alist^[maxerr]+blist^[maxerr]);
-        a2 := b1;
-        b2 := blist^[maxerr];
-        erlast := errmax;
-        qk15i(f, bound, inf, a1, b1, area1, error1, resabs, defab1);
-        qk15i(f, bound, inf, a2, b2, area2, error2, resabs, defab2);
-        area12 := area1+area2;
-        erro12 := error1+error2;
-        errsum := errsum+erro12-errmax;
-        area := area+area12-rlist^[maxerr];
-        If (defab1<>error1) And (defab2<>error2)
-         Then
-         Begin
-           If (abs(rlist^[maxerr]-area12)<=1e-5*abs(area12)) And
-              (erro12>=0.99*errmax)
-            Then If extrap Then Inc(iroff2)
-          Else Inc(iroff1);
-           If (last>10) And (erro12>errmax) Then Inc(iroff3)
-         End;
-        rlist^[maxerr] := area1;
-        rlist^[last] := area2;
-
-        errbnd := epsrel*abs(area);
-        If errbnd<epsabs Then errbnd := epsabs;
-
-        If (iroff1+iroff2>=10) Or (iroff3>=20) Then ier := 2;
-        If (iroff2>=5) Then ierro := 3;
-        If (last=limit) Then ier := 1;
-        h := abs(a1);
-       If h<abs(b2) Then h := abs(b2);
-        If h<=(1+100*macheps)*(abs(a2)+1000*midget) Then ier := 3;
-        If (error2<=error1) Then
-         Begin
-           alist^[last] := a2;
-           blist^[maxerr] := b1;
-           blist^[last] := b2;
-           elist^[maxerr] := error1;
-           elist^[last] := error2
-         End
-       Else
-        Begin
-           alist^[maxerr] := a2;
-           alist^[last] := a1;
-           blist^[last] := b1;
-           rlist^[maxerr] := area2;
-           rlist^[last] := area1;
-           elist^[maxerr] := error2;
-           elist^[last] := error1
-        End;
-        qpsrt(limit, last, maxerr, errmax, elist^[1], iord^[1], nrmax);
-
-        If (errsum<=errbnd) Then continue := false;
-
-        If (ier=0) And continue Then
-         If last=2 Then
-          Begin
-            small := 0.375;
-            erlarg := errsum;
-            ertest := errbnd;
-            rlist2[2] := area
-          End
-       Else
-        If Not noext Then
-         Begin
-           erlarg := erlarg-erlast;
-           If (abs(b1-a1)>small) Then erlarg := erlarg+erro12;
-           break := false;
-           If Not extrap Then
-            If (abs(blist^[maxerr]-alist^[maxerr])>small)
-             Then break := true
-           Else
-            Begin
-                extrap :=  true;
-                nrmax := 2
-            End;
-           If Not break And (ierro<>3) And (erlarg>ertest) Then
-            Begin
-              id := nrmax;
-              jupbnd := last;
-              If (last>(2+limit Div 2)) Then jupbnd := limit+3-last;
-              k := id-1;
-              while (k<jupbnd) and not break 
-              Do
-             Begin
-                 Inc(k);
-                 maxerr := iord^[nrmax];
-                 errmax := elist^[maxerr];
-                 If (abs(blist^[maxerr]-alist^[maxerr])>small)
-                  Then break := true
-                 Else Inc(nrmax)
-              End
-            End;
-           If Not break Then
-            Begin
-              Inc(numrl2);
-              rlist2[numrl2] := area;
-              qelg(numrl2, rlist2, reseps, abseps, res3la, nres);
-              Inc(ktmin);
-
-              If (ktmin>5) And (abserr<1e-3*errsum) Then ier := 4;
-
-              If (abseps<abserr)
-               Then
-               Begin
-                  ktmin := 0;
-                  abserr := abseps;
-                  result := reseps;
-                  correc := erlarg;
-                  ertest := epsrel*abs(reseps);
-                  If epsabs>ertest Then ertest := epsabs;
-                  If (abserr<=ertest) Then continue := false
-               End;
-            End;
-           If continue And Not break Then
-            Begin
-              If (numrl2=1) Then noext := true;
-              If ier<>4 Then
-               Begin
-                 maxerr := iord^[1];
-                 errmax := elist^[maxerr];
-                 nrmax := 1;
-                 extrap :=  false;
-                 small := small*0.5;
-                 erlarg := errsum
-               End
-            End
-         End
-      End;
-
-      h := 0;
- For k := 1 To last Do
-  h := h+rlist^[k];
-      FreeMem(rlist, limit*SizeOf(ArbFloat));
-      FreeMem(alist, limit*SizeOf(ArbFloat));
-      FreeMem(blist, limit*SizeOf(ArbFloat));
-      FreeMem(elist, limit*SizeOf(ArbFloat));
-      FreeMem(iord, limit*SizeOf(ArbInt));
-
-      If (errsum<=errbnd) Or (abserr=giant) Then
-       Begin
-        result := h;
-            abserr := errsum;
-            exit
-       End;
-
-      If (ier+ierro)=0 Then
-       Begin
-           h := abs(result);
-           If h<abs(area) Then h := abs(area);
-           If (ksgn<>-1) Or (h>defabs*0.01) Then
-            If (0.01>result/area) Or (result/area>100) Or (errsum>abs(area))
-             Then ier := 5;
-           exit
-       End;
-
-      If ierro=3 Then abserr := abserr+correc;
-      If ier=0 Then ier := 2;
-
-      If (result<>0) And (area<>0) Then
-       If abserr/abs(result)>errsum/abs(area)
-        Then
-        Begin
-           result := h;
-           abserr := errsum;
-           exit
-        End
-      Else
-       Begin
-           h := abs(result);
-           If h<abs(area) Then h := abs(area);
-           If (ksgn<>-1) Or (h>defabs*0.01) Then
-            If (0.01>result/area) Or (result/area>100) Or (errsum>abs(area))
-             Then ier := 5;
-           exit
-       End;
-
-      If abserr>errsum Then
-       Begin
-        result := h;
-            abserr := errsum;
-            exit
-       End;
-
-      If area<>0
-       Then
-       Begin
-           h := abs(result);
-           If h<abs(area) Then h := abs(area);
-           If (ksgn<>-1) Or (h>defabs*0.01) Then
-            If (0.01>result/area) Or (result/area>100) Or (errsum>abs(area))
-             Then ier := 5
-       End
-End;
-
-Procedure int1fr(f: rfunc1r; a, b, ae: ArbFloat; Var integral, err: ArbFloat;
-                 Var term: ArbInt);
-
-Var neval, ier, last, inf: ArbInt;
-Begin
-     term := 3;
- integral := NaN;
-     If abs(a)=infinity
-      Then If abs(b)=infinity
-            Then If (a=b)
-                  Then exit
-               Else
-                Begin
-                    qagie(f, 0, 2, ae, epsrel, integral, err, ier);
-                    If a=infinity Then integral := -integral
-                End
-          Else If a=-infinity
-                Then qagie(f, b, -1, ae, epsrel, integral, err, ier)
-               Else
-                Begin
-                    qagie(f, b, 1, ae, epsrel, integral, err, ier);
-                    integral := -integral
-                End
-     Else If abs(b)=infinity
-           Then If b=-infinity
-                 Then
-                 Begin
-                    qagie(f, a, -1, ae, epsrel, integral, err, ier);
-                    integral := -integral
-                 End
- Else qagie(f, a, 1, ae, epsrel, integral, err, ier)
-          Else qagse(f, a, b, ae, epsrel, limit, integral, err, neval, ier, last);
-     term := 4;
-     If ier=6 Then term := 3;
-     If ier=0 Then term := 1;
-     If (ier=2) Or (ier=4) Then term := 2
-End;
-
-Begin
-    limit    := 500;
-    epsrel   := 0;
-End.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:43  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:14  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:41  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/inv.pas

@@ -1,284 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Calculate inverses for different kinds of matrices (different with respect
-                 to symmetry)
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-unit inv;
-{$I DIRECT.INC}
-
-interface
-
-uses typ;
-
-{Calc inverse for a matrix with unknown symmetry. General version. }
-procedure invgen(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
-
-{Calc inverse for a symmetrical matrix}
-procedure invgsy(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
-
-{Calc inverse for a positive definite symmetrical matrix}
-procedure invgpd(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
-
-implementation
-
-uses mdt, dsl;
-
-procedure invgen(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
-var
-     success                          : boolean;
-     inn, ii, i, j, k, kk, indexpivot : ArbInt;
-     ca, h, pivot, l, s               : ArbFloat;
-     pa, save                         : ^arfloat1;
-     p                                : ^arint1;
-
-begin
-  if (n<1) or (rwidth<1) then
-  begin
-      term:=3; exit
-  end; {wrong input}
-  pa:=@ai;
-  getmem(p, n*sizeof(ArbInt)); getmem(save, n*sizeof(ArbFloat));
-  mdtgen(n, rwidth, pa^[1], p^[1], ca, term);
-  if term=1 then
-  begin
-      inn:=(n-1)*rwidth+n; pivot:=pa^[inn];
-      if pivot=0 then success:=false else
-      begin
-          success:=true; pa^[inn]:=1/pivot; k:=n;
-          while (k>1) and success do
-          begin
-              k:=k-1; kk:=(k-1)*rwidth;
-              for i:=k+1 to n do save^[i]:=-pa^[(i-1)*rwidth+k];
-              for i:=k+1 to n do
-              begin
-                  ii:=(i-1)*rwidth;
-                  s:=0;
-                  for j:=k+1 to n do s:=s+pa^[ii+j]*save^[j];
-                  pa^[ii+k]:=s
-              end; {i}
-              for j:=k+1 to n do save^[j]:=pa^[kk+j];
-              pivot:=pa^[kk+k];
-              if pivot=0 then success:=false else
-              begin
-                  s:=0;
-                  for i:=k+1 to n do s:=s-save^[i]*pa^[(i-1)*rwidth+k];
-                  pa^[kk+k]:=(1+s)/pivot;
-                  for j:=k+1 to n do
-                  begin
-                      s:=0;
-                      for i:=k+1 to n do s:=s-save^[i]*pa^[(i-1)*rwidth+j];
-                      pa^[(k-1)*rwidth+j]:=s/pivot
-                  end {j}
-              end {pivot <> 0}
-          end; {k}
-          if success then
-          for k:=n downto 1 do
-          begin
-              indexpivot:=p^[k];
-              if indexpivot <> k then
-              for i:=1 to n do
-              begin
-                  ii:=(i-1)*rwidth;
-                  h:=pa^[ii+k]; pa^[ii+k]:=pa^[ii+indexpivot];
-                  pa^[ii+indexpivot]:=h
-              end {i}
-          end {k}
-      end; {pivot <> 0}
-      if (not success) then term:=2
-  end else term:=2;
-  freemem(p, n*sizeof(ArbInt)); freemem(save, n*sizeof(ArbFloat));
-end; {invgen}
-
-procedure invgsy(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
-
-var ind, ind1, i, m, pk, j,
-    kmin1, k, imin2, nsr,
-    imin1, jmin1, iplus1            : ArbInt;
-    success                         : boolean;
-    di, h, ca                       : ArbFloat;
-    pa, l, d, u, v, e, e1, x        : ^arfloat1;
-    p                               : ^arint1;
-    q                               : ^arbool1;
-begin
-  if (n<1) or (rwidth<1) then
-  begin
-      term:=3; exit
-  end; {wrong input}
-  pa:=@ai;
-  getmem(p, n*sizeof(ArbInt)); getmem(q, n*sizeof(boolean));
-  nsr:=n*sizeof(ArbFloat);
-  getmem(l, nsr); getmem(d, nsr); getmem(u, nsr);
-  getmem(v, nsr); getmem(e, nsr); getmem(e1, nsr);
-  getmem(x, ((n+1)*nsr) div 2);
-  mdtgsy(n, rwidth, pa^[1], p^[1], q^[1], ca, term);
-  if term=1 then
-  begin
-      success:=true; i:=1; ind:=1;
-      while (i<>n+1) and success do
-      begin
-          success:=pa^[ind]<>0; ind:=ind+rwidth+1; i:=i+1
-      end; {i}
-      if success then
-      begin
-          d^[1]:=pa^[1]; di:=d^[1]; l^[1]:=pa^[rwidth+1];
-          d^[2]:=pa^[rwidth+2]; di:=d^[2]; u^[1]:=pa^[2];
-          imin1:=1; i:=2;
-          while i<n do
-          begin
-              imin2:=imin1; imin1:=i; i:=i+1; ind:=imin1*rwidth;
-              l^[imin1]:=pa^[ind+imin1]; d^[i]:=pa^[ind+i]; di:=d^[i];
-              u^[imin1]:=pa^[ind-rwidth+i]; v^[imin2]:=pa^[ind-2*rwidth+i]
-          end; {i}
-          m:=0; k:=0;
-          while k<n do
-          begin
-              kmin1:=k; k:=k+1;
-              for i:=1 to kmin1 do e^[i]:=0;
-              e^[k]:=1; i:=k;
-              while i<n do
-              begin
-                  imin1:=i; i:=i+1; h:=0;
-                  if k=1 then j:=1 else j:=kmin1;
-                  while j<imin1 do
-                  begin
-                      jmin1:=j; j:=j+1;
-                      h:=h-pa^[(i-1)*rwidth+jmin1]*e^[j]
-                  end; {j}
-                  e^[i]:=h
-              end; {i}
-              dslgtr(n, l^[1], d^[1], u^[1], v^[1], q^[1],
-                     e^[1], e1^[1], term);
-              i:=n+1; imin1:=n;
-              while i>2 do
-              begin
-                  iplus1:=i; i:=imin1; imin1:=imin1-1; h:=e1^[i];
-                  for j:=iplus1 to n do
-                    h:=h-pa^[(j-1)*rwidth+imin1]*e1^[j];
-                  e1^[i]:=h
-              end; {i}
-              for i:=k to n do
-              begin
-                  m:=m+1; x^[m]:=e1^[i]
-              end
-          end; {k}
-          m:=0;
-          for k:=1 to n do for i:=k to n do
-          begin
-              m:=m+1; pa^[(i-1)*rwidth+k]:=x^[m]
-          end; {i,k}
-          for k:=n-1 downto 2 do
-          begin
-              pk:=p^[k];
-              if pk <> k then
-              begin
-                  kmin1:=k-1; ind:=(k-1)*rwidth; ind1:=(pk-1)*rwidth;
-                  for j:=1 to kmin1 do
-                  begin
-                      h:=pa^[ind+j];
-                      pa^[ind+j]:=pa^[ind1+j]; pa^[ind1+j]:=h
-                  end; {j}
-                  for j:=pk downto k do
-                  begin
-                      ind:=(j-1)*rwidth;
-                      h:=pa^[ind+k];
-                      pa^[ind+k]:=pa^[ind1+j]; pa^[ind1+j]:=h
-                  end; {j}
-                  for i:=pk to n do
-                  begin
-                      ind:=(i-1)*rwidth;
-                      h:=pa^[ind+k];
-                      pa^[ind+k]:=pa^[ind+pk]; pa^[ind+pk]:=h
-                  end {i}
-              end {pk <> k}
-          end {k}
-      end; {success}
-      if (not success) then term:=2 else
-      for i:=1 to n do
-      begin
-          ind:=(i-1)*rwidth;
-          for j:=i+1 to n do pa^[ind+j]:=pa^[(j-1)*rwidth+i]
-      end {i}
-  end else term:=2;
-  freemem(l, nsr); freemem(d, nsr); freemem(u, nsr);
-  freemem(v, nsr); freemem(e, nsr); freemem(e1, nsr);
-  freemem(x, ((n+1)*nsr) div 2);
-end; {invgsy}
-
-procedure invgpd(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
-var success             : boolean;
-    i, j, k, kmin1, ind : ArbInt;
-    tk, h, ca           : ArbFloat;
-    pa, t               : ^arfloat1;
-begin
-  if (n<1) or (rwidth<1) then
-  begin
-      term:=3; exit
-  end; {wrong input}
-  pa:=@ai;
-  mdtgpd(n, rwidth, pa^[1], ca, term);
-  getmem(t, n*sizeof(ArbFloat));
-  if term=1 then
-  begin
-      success:=true; ind:=1; k:=1;
-      while (k<>n+1) and success do
-      begin
-          success:=pa^[ind]<>0; k:=k+1; ind:=ind+rwidth+1
-      end; {k}
-      if success then
-      begin
-          for k:=n downto 1 do
-          begin
-              for i:=k to n do t^[i]:=pa^[(i-1)*rwidth+k];
-              tk:=t^[k];
-              for i:=n downto k do
-              begin
-                  if i=k then h:=1/tk else h:=0;
-                  ind:=(i-1)*rwidth;
-                  for j:=k+1 to i do h:=h-pa^[ind+j]*t^[j];
-                  for j:=i+1 to n do h:=h-pa^[(j-1)*rwidth+i]*t^[j];
-                  pa^[ind+k]:=h/tk
-              end {i}
-          end {k}
-      end; {success}
-      if (not success) then term:=2 else
-      for i:=1 to n do
-      begin
-          ind:=(i-1)*rwidth;
-          for j:=i+1 to n do pa^[ind+j]:=pa^[(j-1)*rwidth+i]
-      end; {i}
-  end; {term=1}
-  freemem(t, n*sizeof(ArbFloat));
-end; {invgpd}
-end.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:44  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:14  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/iom.pas

@@ -1,127 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Basic In and output of matrix and vector types. Maybe too simple for
-    your application, but still handy for logging and debugging.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-unit iom;
-
-interface
-{$I direct.inc}
-
-uses typ;
-
-const
-    npos  : ArbInt = 78;
-
-{Read a n-dimensional vector v from textfile}
-procedure iomrev(var inp: text; var v: ArbFloat; n: ArbInt);
-
-{Read a m x n-dimensional matrix a from textfile}
-procedure iomrem(var inp: text; var a: ArbFloat; m, n, rwidth: ArbInt);
-
-{Write a n-dimensional vectorv v to textfile}
-procedure iomwrv(var out: text; var v: ArbFloat; n, form: ArbInt);
-
-{Write a m x n-dimensional matrix a to textfile}
-procedure iomwrm(var out: text; var a: ArbFloat; m, n, rwidth, form: ArbInt);
-
-implementation
-
-procedure iomrev(var inp: text; var v: ArbFloat; n: ArbInt);
-
-var pv : ^arfloat1;
-     i : ArbInt;
-
-BEGIN
-  pv:=@v; for i:=1 to n do read(inp, pv^[i])
-END {iomrev};
-
-procedure iomrem(var inp: text; var a: ArbFloat; m, n, rwidth: ArbInt);
-
-var    pa : ^arfloat1;
-     i, k : ArbInt;
-
-BEGIN
-  pa:=@a; k:=1;
-  for i:=1 to m do
-    BEGIN
-      iomrev(inp, pa^[k], n); Inc(k, rwidth)
-    END
-END {iomrem};
-
-procedure iomwrv(var out: text; var v: ArbFloat; n, form: ArbInt);
-
-var  pv     : arfloat1 absolute v;
-     i, i1  : ArbInt;
-BEGIN
-  if form>maxform then form:=maxform  else
-  if form<minform then form:=minform;
-  i1:=npos div (form+2);
-  for i:=1 to n do
-  if ((i mod i1)=0) or (i=n) then writeln(out, pv[i]:form)
-                             else write(out, pv[i]:form, '':2)
-END {iomwrv};
-
-procedure iomwrm(var out: text; var a: ArbFloat; m, n, rwidth, form: ArbInt);
-
-var  pa                            : ^arfloat1;
-     i, k, nb, i1, l, j, r, l1, kk : ArbInt;
-
-BEGIN
-  if (n<1) or (m<1) then exit;
-  pa:=@a;
-  if form>maxform then form:=maxform else
-  if form<minform then form:=minform;
-  i1:=npos div (form+2); l1:=0;
-  nb:=n div i1; r:=n mod i1;
-  if r>0 then Inc(nb);
-  for l:=1 to nb do
-    BEGIN
-      k:=l1+1; if (r>0) and (l=nb) then i1:=r;
-      for i:=1 to m do
-        BEGIN
-          kk:=k;
-          for j:=1 to i1-1 do
-            BEGIN
-              write(out, pa^[kk]:form, '':2); Inc(kk)
-            END;
-          writeln(out, pa^[kk]:form); Inc(k, rwidth)
-        END;
-      Inc(l1, i1); if l<nb then writeln(out)
-    END;
-END {iomwrm};
-
-END.
-
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:44  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:14  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/ipf.pas

@@ -1,899 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Interpolate and (curve) fitting.
-    Slegpb in this unit patched parameters slightly. Units IPF and sle
-    were not in the same revision in this numlib copy (which was a
-    copy of the work directory of the author) .
-
-    Contains two undocumented functions. If you recognize the algoritm,
-    mail us.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-{
- }
-unit ipf;
-{$I direct.inc}
-interface
-
-uses typ, mdt, dsl, sle, spe;
-
-{ Determine natural cubic spline "s" for data set (x,y), output to (a,d2a)
- term=1 success,
-     =2 failure calculating "s"
-     =3 wrong input (e.g. x,y is not sorted increasing on x)}
-procedure ipffsn(n: ArbInt; var x, y, a, d2a: ArbFloat; var term: ArbInt);
-
-{calculate d2s from x,y, which can be used to calculate s}
-procedure ipfisn(n: ArbInt; var x, y, d2s: ArbFloat; var term: ArbInt);
-
-{Calculate function value for dataset (x,y), with n.c. spline d2s for
-x value t. Return (corrected) y value.
-s calculated from x,y, with e.g. ipfisn}
-function  ipfspn(n: ArbInt; var x, y, d2s: ArbFloat; t: ArbFloat;
-                 var term: ArbInt): ArbFloat;
-
-{Calculate n-degree polynomal b for dataset (x,y) with n elements
- using the least squares method.}
-procedure ipfpol(m, n: ArbInt; var x, y, b: ArbFloat; var term: ArbInt);
-
-
-                {**** undocumented ****}
-
-function spline(    n     : ArbInt;
-                    x     : complex;
-                var ac    : complex;
-                var gammar: ArbFloat;
-                    u1    : ArbFloat;
-                    pf    : complex): ArbFloat;
-
-                {**** undocumented ****}
-
-procedure splineparameters
-          (    n                 : ArbInt;
-           var ac, alfadc        : complex;
-           var lambda,
-               gammar, u1,
-               kwsom, energie    : ArbFloat;
-           var pf                : complex);
-
-implementation
-
-
-procedure ipffsn(n: ArbInt; var x, y, a, d2a: ArbFloat; var term: ArbInt);
-
-var                    i, j, sr, n1s, ns1, ns2: ArbInt;
-   s, lam, lam0, lam1, lambda, ey, ca, p, q, r: ArbFloat;
-     px, py, pd, pa, pd2a,
-  h, z, diagb, dinv, qty, qtdinvq, c, t, tl: ^arfloat1;
-                                         ub: boolean;
-
-  procedure solve; {n, py, qty, h, qtdinvq, dinv, lam, t, pa, pd2a, term}
-  var i: ArbInt;
-      p, q, r, ca: ArbFloat;
-             f, c: ^arfloat1;
-  begin
-    getmem(f, 3*ns1); getmem(c, ns1);
-    for i:=1 to n-1 do
-      begin
-        f^[3*i]:=qtdinvq^[3*i]+lam*t^[2*i];
-        if i > 1
-        then
-          f^[3*i-1]:=qtdinvq^[3*i-1]+lam*t^[2*i-1];
-        if i > 2
-        then
-          f^[3*i-2]:=qtdinvq^[3*i-2];
-        if lam=0
-        then
-          c^[i]:=qty^[i]
-        else
-          c^[i]:=lam*qty^[i]
-      end;
-    slegpb(n-1, 2,{ 3,} f^[1], c^[1], pd2a^[1], ca, term);
-    if term=2
-    then
-      begin
-        freemem(f, 3*ns1); freemem(c, ns1);
-        exit
-      end;
-    p:=1/h^[1];
-    if lam=0
-    then
-      r:=1
-    else
-      r:=1/lam;
-    q:=1/h^[2]; pa^[1]:=py^[1]-r*dinv^[1]*p*pd2a^[1];
-    pa^[2]:=py^[2]-r*dinv^[2]*(pd2a^[2]*q-(p+q)*pd2a^[1]); p:=q;
-    for i:=3 to n-1 do
-      begin
-        q:=1/h^[i];
-        pa^[i]:=py^[i]-r*dinv^[i]*
-                (p*pd2a^[i-2]-(p+q)*pd2a^[i-1]+q*pd2a^[i]);
-        p:=q
-      end;
-    q:=1/h^[n];
-    pa^[n]:=py^[n]-r*dinv^[n]*(p*pd2a^[n-2]-(p+q)*pd2a^[n-1]);
-    pa^[n+1]:=py^[n+1]-r*dinv^[n+1]*q*pd2a^[n-1];
-    if lam=0
-    then
-      for i:=1 to n-1 do
-        pd2a^[i]:=0;
-    freemem(f, 3*ns1); freemem(c, ns1);
-  end; {solve}
-
-    function e(var c, h: ArbFloat; n:ArbInt): ArbFloat;
-    var i:ArbInt;
-        s:ArbFloat;
-        pc, ph: ^arfloat1;
-    begin
-      ph:=@h; pc:=@c;
-      s:=ph^[1]*pc^[1]*pc^[1];
-      for i:=1 to n-2 do
-        s:=s+(pc^[i]*(pc^[i]+pc^[i+1])+pc^[i+1]*pc^[i+1])*ph^[i+1];
-      e:=(s+pc^[n-1]*pc^[n-1]*ph^[n])/3
-    end; {e}
-
-    function cr(lambda: ArbFloat): ArbFloat;
-    var s, crs: ArbFloat;
-             i: ArbInt;
-    begin
-      cr:=0; lam:=lambda;
-      solve; { n, py, qty, h, qtdinvq, dinv, lam, t, pa, pd2a, term }
-      if term=2
-      then
-        exit;
-      crs:=ey;
-      if lam <> 0
-      then
-        begin
-          crs:=crs+e(pd2a^[1], h^[1], n);
-          s:=0;
-          for i:=1 to n-1 do
-            s:=s+pd2a^[i]*qty^[i];
-          crs:=crs-2*s
-        end;
-      s:=0;
-      for i:=1 to n+1 do
-        s:=s+sqr(pa^[i]-py^[i])*diagb^[i];
-      cr:=crs-s
-    end; {cr}
-
-    procedure roof1r(a, b, ae, re: ArbFloat; var x: ArbFloat);
-
-    var fa, fb, c, fc, m, tol, w1, w2 : ArbFloat;
-                                    k : ArbInt;
-                                 stop : boolean;
-
-    begin
-      fa:=cr(a);
-      if term=2
-      then
-        exit;
-      fb:=cr(b);
-      if term=2
-      then
-        exit;
-      if abs(fb)>abs(fa)
-      then
-        begin
-          c:=b; fc:=fb; x:=a; b:=a; fb:=fa; a:=c; fa:=fc
-        end
-      else
-        begin
-          c:=a; fc:=fa; x:=b
-        end;
-      k:=0;
-      tol:=ae+re*spemax(abs(a), abs(b));
-      w1:=abs(b-a); stop:=false;
-      while (abs(b-a)>tol) and (fb<>0) and (not stop) do
-        begin
-          m:=(a+b)/2;
-          if (k>=2) or (fb=fc)
-          then
-            x:=m
-          else
-            begin
-              x:=(b*fc-c*fb)/(fc-fb);
-              if abs(b-x)<tol
-              then
-                x:=b-tol*spesgn(b-a);
-              if spesgn(x-m)=spesgn(x-b)
-              then
-                x:=m
-            end;
-          c:=b; fc:=fb; b:=x; fb:=cr(x);
-          if term=2
-          then
-            exit;
-          if spesgn(fa)*spesgn(fb)>0
-          then
-            begin
-              a:=c; fa:=fc; k:=0
-            end
-          else
-            k:=k+1;
-          if abs(fb)>=abs(fa)
-          then
-            begin
-              c:=b; fc:=fb; x:=a; b:=a; fb:=fa; a:=c; fa:=fc; k:=0
-            end;
-          tol:=ae+re*spemax(abs(a), abs(b));
-          w2:=abs(b-a);
-          if w2>=w1
-          then
-            stop:=true;
-          w1:=w2
-        end
-    end; {roof1r}
-
-procedure NoodGreep;
-var I, j: ArbInt;
-begin
-  i:=1;
-  while i <= n do
-    begin
-      if (pd^[i] <= 0) or (px^[i+1] <= px^[i])
-      then
-        begin
-          term:=3;
-          exit
-        end;
-      i:=i+1
-    end;
-  if pd^[n+1] <= 0
-  then
-    begin
-      term:=3;
-      exit
-    end;
-  for i:=1 to n+1 do
-    dinv^[i]:=1/pd^[i];
-  for i:=1 to n do
-    h^[i]:=px^[i+1]-px^[i];
-  t^[2]:=(h^[1]+h^[2])/3;
-  for i:=2 to n-1 do
-    begin
-      t^[2*i]:=(h^[i]+h^[i+1])/3; t^[2*i-1]:=h^[i]/6
-    end;
-  move(t^[1], tl^[1], ns2);
-  mdtgpb(n-1, 1, 2, tl^[1], ca, term);
-  if term=2
-  then
-    exit;
-  z^[1]:=1/(h^[1]*tl^[2]);
-  for j:=2 to n-1 do
-    z^[j]:=-(tl^[2*j-1]*z^[j-1])/tl^[2*j];
-  s:=0;
-  for j:=1 to n-1 do
-    s:=s+sqr(z^[j]);
-  diagb^[1]:=s;
-  z^[1]:=(-1/h^[1]-1/h^[2])/tl^[2];
-  if n>2
-  then
-    z^[2]:=(1/h^[2]-tl^[3]*z^[1])/tl^[4];
-  for j:=3 to n-1 do
-    z^[j]:=-tl^[2*j-1]*z^[j-1]/tl^[2*j];
-  s:=0;
-  for j:=1 to n-1 do
-    s:=s+sqr(z^[j]);
-  diagb^[2]:=s;
-  for i:=2 to n-2 do
-    begin
-      z^[i-1]:=1/(h^[i]*tl^[2*(i-1)]);
-      z^[i]:=(-1/h^[i]-1/h^[i+1]-tl^[2*i-1]*z^[i-1])/tl^[2*i];
-      z^[i+1]:=(1/h^[i+1]-tl^[2*i+1]*z^[i])/tl^[2*(i+1)];
-      for j:=i+2 to n-1 do
-        z^[j]:=-tl^[2*j-1]*z^[j-1]/tl^[2*j];
-      s:=0;
-      for j:=i-1 to n-1 do
-        s:=s+sqr(z^[j]);
-      diagb^[i+1]:=s
-    end;
-  z^[n-2]:=1/(h^[n-1]*tl^[2*(n-2)]);
-  z^[n-1]:=(-1/h^[n-1]-1/h^[n]-tl^[2*n-3]*z^[n-2])/tl^[2*(n-1)];
-  s:=0;
-  for j:=n-2 to n-1 do
-    s:=s+sqr(z^[j]);
-  diagb^[n]:=s;
-  diagb^[n+1]:=1/sqr(h^[n]*tl^[2*(n-1)]);
-  p:=1/h^[1];
-  for i:=2 to n do
-    begin
-      q:=1/h^[i]; qty^[i-1]:=py^[i+1]*q-py^[i]*(p+q)+py^[i-1]*p;
-      p:=q
-    end;
-  p:=1/h^[1]; q:=1/h^[2]; r:=1/h^[3];
-  qtdinvq^[3]:=dinv^[1]*p*p+dinv^[2]*(p+q)*(p+q)+dinv^[3]*q*q;
-  if n>2
-  then
-    begin
-      qtdinvq^[6]:=dinv^[2]*q*q+dinv^[3]*(q+r)*(q+r)+dinv^[4]*r*r;
-      qtdinvq^[5]:=-(dinv^[2]*(p+q)+dinv^[3]*(q+r))*q;
-      p:=q; q:=r;
-      for i:=3 to n-1 do
-        begin
-          r:=1/h^[i+1];
-          qtdinvq^[3*i]:=dinv^[i]*q*q+dinv^[i+1]*(q+r)*(q+r)+dinv^[i+2]*r*r;
-          qtdinvq^[3*i-1]:=-(dinv^[i]*(p+q)+dinv^[i+1]*(q+r))*q;
-          qtdinvq^[3*i-2]:=dinv^[i]*p*q;
-          p:=q; q:=r
-        end
-    end;
-  dslgpb(n-1, 1, 2, tl^[1], qty^[1], c^[1], term);
-  if term=2
-  then
-    exit;
-  ey:=e(c^[1], h^[1], n);
-  lam0:=0;
-  s:=cr(lam0);
-  if term=2
-  then
-    exit;
-  if s >= 0
-  then
-    begin
-      lambda:=0; term:=4
-    end
-  else
-    begin
-      lam1:=1e-8; ub:=false;
-      while (not ub) and (lam1<=1.1e8) do
-        begin
-          s:=cr(lam1);
-          if term=2
-          then
-            exit;
-          if s  >= 0
-          then
-            ub:=true
-          else
-            begin
-              lam0:=lam1; lam1:=10*lam1
-            end
-        end;
-      if not ub
-      then
-        begin
-          term:=4; lambda:=lam0
-        end
-      else
-        roof1r(lam0, lam1, 0, 1e-6, lambda);
-      if term=2
-      then
-        exit
-    end;
-
-end;
-
-begin
-  term:=1;
-  if n < 2
-  then
-    begin
-      term:=3; exit
-    end;
-  sr:=sizeof(ArbFloat);
-  n1s:=(n+1)*sr;
-  ns2:=2*(n-1)*sr;
-  ns1:=(n-1)*sr;
-  getmem(dinv, n1s);
-  getmem(h, n*sr);
-  getmem(t, ns2);
-  getmem(tl, ns2);
-  getmem(z, ns1);
-  getmem(diagb, n1s);
-  getmem(qtdinvq, 3*ns1);
-  getmem(c, ns1);
-  getmem(qty, ns1);
-
-   getmem(pd, n1s);
- { pd:=@d; }
-  px:=@x;
-  py:=@y;
-  pa:=@a;
-  pd2a:=@d2a;
-  { de gewichten van de punten worden op 1 gezet}
-  for i:=1 to n+1 do
-    pd^[i]:=1;
-
-  NoodGreep;
-
-  freemem(dinv, n1s);
-  freemem(h, n*sr);
-  freemem(t, ns2);
-  freemem(tl, ns2);
-  freemem(z, ns1);
-  freemem(diagb, n1s);
-  freemem(qtdinvq, 3*ns1);
-  freemem(c, ns1);
-  freemem(qty, ns1);
-
-  freemem(pd, n1s);
-end; {ipffsn}
-
-procedure ortpol(m, n: ArbInt; var x, alfa, beta: ArbFloat);
-
-var
-                             i, j, ms : ArbInt;
-    xppn1, ppn1, ppn, p, alfaj, betaj : ArbFloat;
-               px, pal, pbe, pn, pn1 : ^arfloat1;
-                                 temp : pointer;
-begin
-  mark(temp);
-  px:=@x; pal:=@alfa; pbe:=@beta; ms:=m*sizeof(ArbFloat);
-  getmem(pn, ms); getmem(pn1, ms);
-  xppn1:=0; ppn1:=m;
-  for i:=1 to m do
-    begin
-      pn^[i]:=0; pn1^[i]:=1; xppn1:=xppn1+px^[i]
-    end;
-  pal^[1]:=xppn1/ppn1; pbe^[1]:=0;
-  for j:=2 to n do
-    begin
-      alfaj:=pal^[j-1]; betaj:=pbe^[j-1];
-      ppn:=ppn1; ppn1:=0; xppn1:=0;
-      for i:=1 to m do
-        begin
-          p:=(px^[i]-alfaj)*pn1^[i]-betaj*pn^[i];
-          pn^[i]:=pn1^[i]; pn1^[i]:=p; p:=p*p;
-          ppn1:=ppn1+p; xppn1:=xppn1+px^[i]*p
-        end; {i}
-      pal^[j]:=xppn1/ppn1; pbe^[j]:=ppn1/ppn
-    end; {j}
-  release(temp)
-end; {ortpol}
-
-procedure ortcoe(m, n: ArbInt; var x, y, alfa, beta, a: ArbFloat);
-
-var                        i, j, mr : ArbInt;
-         fpn, ppn, p, alphaj, betaj : ArbFloat;
-    px, py, pal, pbe, pa, pn, pn1 : ^arfloat1;
-                               temp : pointer;
-
-begin
-  mark(temp); mr:=m*sizeof(ArbFloat);
-  px:=@x; py:=@y; pal:=@alfa; pbe:=@beta; pa:=@a;
-  getmem(pn, mr); getmem(pn1, mr);
-  fpn:=0;
-  for i:=1 to m do
-    begin
-      pn^[i]:=0; pn1^[i]:=1; fpn:=fpn+py^[i]
-    end; {i}
-  pa^[1]:=fpn/m;
-  for j:=1 to n do
-    begin
-      fpn:=0; ppn:=0; alphaj:=pal^[j]; betaj:=pbe^[j];
-      for i:=1 to m do
-        begin
-          p:=(px^[i]-alphaj)*pn1^[i]-betaj*pn^[i];
-          pn^[i]:=pn1^[i]; pn1^[i]:=p;
-          fpn:=fpn+py^[i]*p; ppn:=ppn+p*p
-        end; {i}
-      pa^[j+1]:=fpn/ppn
-    end; {j}
-  release(temp)
-end; {ortcoe}
-
-procedure polcoe(n:ArbInt; var alfa, beta, a, b: ArbFloat);
-
-var            k, j : ArbInt;
-           pal, pbe : ^arfloat1;
-            pa, pb  : ^arfloat0;
-
-begin
-  pal:=@alfa; pbe:=@beta; pa:=@a; pb:=@b;
-  move(pa^[0], pb^[0], (n+1)*sizeof(ArbFloat));
-  for j:=0 to n-1 do
-    for k:=n-j-1 downto 0 do
-      begin
-        pb^[k+j]:=pb^[k+j]-pal^[k+1]*pb^[k+j+1];
-        if k+j<>n-1
-        then
-          pb^[k+j]:=pb^[k+j]-pbe^[k+2]*pb^[k+j+2]
-      end
-end; {polcoe}
-
-procedure ipfpol(m, n: ArbInt; var x, y, b: ArbFloat; var term: ArbInt);
-
-var                      i, ns: ArbInt;
-                          fsum: ArbFloat;
-            px, py, alfa, beta: ^arfloat1;
-                         pb, a: ^arfloat0;
-begin
-  if (n<0) or (m<1)
-  then
-    begin
-      term:=3; exit
-    end;
-  term:=1;
-  if n = 0
-  then
-    begin
-      py:=@y; pb:=@b;
-      fsum:=0;
-      for i:=1 to m do
-        fsum:=fsum+py^[i];
-      pb^[0]:=fsum/m
-    end
-  else
-    begin
-      if n>m-1
-      then
-        begin
-          pb:=@b;
-          fillchar(pb^[m], (n-m+1)*sizeof(ArbFloat), 0);
-          n:=m-1
-        end;
-      ns:=n*sizeof(ArbFloat);
-      getmem(alfa, ns); getmem(beta, ns);
-      getmem(a, (n+1)*sizeof(ArbFloat));
-      ortpol(m, n, x, alfa^[1], beta^[1]);
-      ortcoe(m, n, x, y, alfa^[1], beta^[1], a^[0]);
-      polcoe(n, alfa^[1], beta^[1], a^[0], b);
-      freemem(alfa, ns); freemem(beta, ns);
-      freemem(a, (n+1)*sizeof(ArbFloat));
-    end
-end; {ipfpol}
-
-procedure ipfisn(n: ArbInt; var x, y, d2s: ArbFloat; var term: ArbInt);
-
-var
-                   s, i : ArbInt;
-               p, q, ca : ArbFloat;
-        px, py, h, b, t : ^arfloat0;
-                   pd2s : ^arfloat1;
-begin
-  px:=@x; py:=@y; pd2s:=@d2s;
-  term:=1;
-  if n < 2
-  then
-    begin
-      term:=3; exit
-    end; {n<2}
-  s:=sizeof(ArbFloat);
-  getmem(h, n*s);
-  getmem(b, (n-1)*s);
-  getmem(t, 2*(n-1)*s);
-  for i:=0 to n-1 do
-    h^[i]:=px^[i+1]-px^[i];
-  q:=1/6; p:=2*q;
-  t^[1]:=p*(h^[0]+h^[1]);
-  for i:=2 to n-1 do
-    begin
-      t^[2*i-1]:=p*(h^[i-1]+h^[i]); t^[2*i-2]:=q*h^[i-1]
-    end; {i}
-  p:=1/h^[0];
-  for i:=2 to n do
-    begin
-      q:=1/h^[i-1]; b^[i-2]:=py^[i]*q-py^[i-1]*(p+q)+py^[i-2]*p; p:=q
-    end;
-  slegpb(n-1, 1, {2,} t^[0], b^[0], pd2s^[1], ca, term);
-  freemem(h, n*s);
-  freemem(b, (n-1)*s);
-  freemem(t, 2*(n-1)*s);
-end; {ipfisn}
-
-function ipfspn(n: ArbInt; var x, y, d2s: ArbFloat; t:ArbFloat;
-                var term: ArbInt): ArbFloat;
-
-var
-   px, py       : ^arfloat0;
-   pd2s         : ^arfloat1;
-   i, j, m      : ArbInt;
-   d, s3, h, dy : ArbFloat;
-begin
-  i:=1; term:=1;
-  if n<2
-  then
-    begin
-      term:=3; exit
-    end; {n<2}
-  px:=@x; py:=@y; pd2s:=@d2s;
-  if t <= px^[0]
-  then
-    begin
-      h:=px^[1]-px^[0];
-      dy:=(py^[1]-py^[0])/h-h*pd2s^[1]/6;
-      ipfspn:=py^[0]+(t-px^[0])*dy
-    end { t <= x[0] }
-  else
-  if t >= px^[n]
-  then
-    begin
-      h:=px^[n]-px^[n-1];
-      dy:=(py^[n]-py^[n-1])/h+h*pd2s^[n-1]/6;
-      ipfspn:=py^[n]+(t-px^[n])*dy
-    end { t >= x[n] }
-  else
-    begin
-      i:=0; j:=n;
-      while j <> i+1 do
-        begin
-          m:=(i+j) div 2;
-          if t>=px^[m]
-          then
-            i:=m
-          else
-            j:=m
-        end; {j}
-      h:=px^[i+1]-px^[i];
-      d:=t-px^[i];
-      if i=0
-      then
-        begin
-          s3:=pd2s^[1]/h;
-          dy:=(py^[1]-py^[0])/h-h*pd2s^[1]/6;
-          ipfspn:=py^[0]+d*(dy+d*d*s3/6)
-        end
-      else
-      if i=n-1
-      then
-        begin
-          s3:=-pd2s^[n-1]/h;
-          dy:=(py^[n]-py^[n-1])/h-h*pd2s^[n-1]/3;
-          ipfspn:=py^[n-1]+d*(dy+d*(pd2s^[n-1]/2+d*s3/6))
-        end
-      else
-        begin
-          s3:=(pd2s^[i+1]-pd2s^[i])/h;
-          dy:=(py^[i+1]-py^[i])/h-h*(2*pd2s^[i]+pd2s^[i+1])/6;
-          ipfspn:=py^[i]+d*(dy+d*(pd2s^[i]/2+d*s3/6))
-        end
-   end  { x[0] < t < x[n] }
-end; {ipfspn}
-
-function p(x, a, z:complex): ArbFloat;
-begin
-      x.sub(a);
-      p:=x.Inp(z)
-end;
-
-function e(x, y: complex): ArbFloat;
-const c1: ArbFloat = 0.01989436788646;
-var s: ArbFloat;
-begin x.sub(y);
-      s := x.norm;
-      if s=0 then e:=0 else e:=c1*s*ln(s)
-end;
-
-function spline(    n     : ArbInt;
-                    x     : complex;
-                var ac    : complex;
-                var gammar: ArbFloat;
-                    u1    : ArbFloat;
-                    pf    : complex): ArbFloat;
-var i     : ArbInt;
-    s     : ArbFloat;
-    a     : arcomp0 absolute ac;
-    gamma : arfloat0 absolute gammar;
-begin
-    s := u1 + p(x, a[n-2], pf);
-    for i:=0 to n do s := s + gamma[i]*e(x,a[i]);
-    spline := s
-end;
-
-procedure splineparameters
-          (    n                 : ArbInt;
-           var ac, alfadc        : complex;
-           var lambda,
-               gammar, u1,
-               kwsom, energie    : ArbFloat;
-           var pf                : complex);
-
-   procedure SwapC(var v, w: complex);
-   var x: complex;
-   begin
-       x := v; v := w; w := x
-   end;
-
-   procedure pxpy(a, b, c: complex; var p:complex);
-   var det: ArbFloat;
-   begin
-        b.sub(a); c.sub(a); det := b.xreal*c.imag-b.imag*c.xreal;
-        b.sub(c); p.Init(b.imag/det, -b.xreal/det)
-   end;
-
-   procedure pfxpfy(a, b, c: complex; f: vector; var pf: complex);
-   begin
-      b.sub(a); c.sub(a);
-      f.j := f.j-f.i; f.k := f.k-f.i;
-      pf.init(f.j*c.imag - f.k*b.imag, -f.j*c.xreal + f.k*b.xreal);
-      pf.scale(1/(b.xreal*c.imag - b.imag*c.xreal))
-   end;
-
-   function InpV(n: ArbInt; var v1, v2: ArbFloat): ArbFloat;
-   var i: ArbInt;
-       a1: arfloat0 absolute v1;
-       a2: arfloat0 absolute v2;
-       s : ArbFloat;
-   begin
-       s := 0;
-       for i:=0 to n-1 do s := s + a1[i]*a2[i];
-       InpV := s
-   end;
-
-   PROCEDURE SPDSOL(    N  : INTEGER;
-                    VAR AP : pointer;
-                    VAR B  : ArbFloat);
-   VAR I, J, K : INTEGER;
-       H       : ArbFloat;
-       a       : ^ar2dr absolute ap;
-       bx      : arfloat0 absolute b;
-   BEGIN
-      for k:=0 to n do
-      BEGIN
-          h := sqrt(a^[k]^[k]-InpV(k, a^[k]^[0], a^[k]^[0]));
-          a^[k]^[k] := h;
-          FOR I:=K+1 TO N do a^[i]^[k] := (a^[i]^[k] - InpV(k, a^[k]^[0], a^[i]^[0]))/h;
-          BX[K] := (bx[k] - InpV(k, a^[k]^[0], bx[0]))/h
-      END;
-      FOR I:=N DOWNTO 0 do
-      BEGIN
-          H := BX[I];
-          FOR J:=I+1 TO N DO H := H - A^[J]^[I]*BX[J];
-          BX[I] := H/A^[I]^[I]
-      END
-   END;
-
-var i, j, i1 : ArbInt;
-    x, h,
-    absdet,
-    absdetmax,
-    s, s1, ca: ArbFloat;
-    alfa, dv, hulp,
-    u, v, w  : vector;
-    e22      : array[0..2] of vector;
-    e21, b   : ^arvect0;
-    k, c     : ^ar2dr;
-    gamma    : arfloat0 absolute gammar;
-    an2, an1, an, z,
-    vz, wz   : complex;
-    a        : arcomp0 absolute ac;
-    alfad    : arcomp0 absolute alfadc;
-
-begin
-
-  i1:=0;
-  x:=a[0].xreal;
-  for i:=1 to n do
-  begin
-       h:=a[i].xreal;
-       if h<x then begin i1:=i; x:=h end
-  end;
-  SwapC(a[n-2], a[i1]);
-  SwapC(alfad[n-2], alfad[i1]);
-
-  x:=a[0].xreal;
-  i1 := 0;
-  for i:=1 to n do
-  begin
-       h:=a[i].xreal;
-       if h>x then begin i1:=i; x:=h end
-  end;
-  SwapC(a[n-1], a[i1]);
-  SwapC(alfad[n-1], alfad[i1]);
-
-  vz := a[n-2]; vz.sub(a[n-1]);
-
-  absdetmax := -1;
-  for i:=0 to n do
-  begin
-    wz := a[i]; wz.sub(a[n-2]);
-    absdet := abs(wz.imag*vz.xreal-wz.xreal*vz.imag);
-    if absdet>absdetmax then begin i1:=i; absdetmax:=absdet end
-  end;
-  SwapC(a[n], a[i1]);
-  SwapC(alfad[n], alfad[i1]);
-
-  an2 := a[n-2]; an1 := a[n-1]; an := a[n];
-  alfa.i := alfad[n-2].xreal; dv.i := alfad[n-2].imag;
-  alfa.j := alfad[n-1].xreal; dv.j := alfad[n-1].imag;
-  alfa.k := alfad[n  ].xreal; dv.k := alfad[n  ].imag;
-
-  n := n - 3;
-
-  GetMem(k, (n+1)*SizeOf(pointer));
-  for j:=0 to n do GetMem(k^[j], (j+1)*SizeOf(ArbFloat));
-
-  GetMem(e21, (n+1)*SizeOf(vector));
-  GetMem(b, (n+1)*SizeOf(vector));
-
-  pxpy(an2,an1,an,z); for i:=0 to n do b^[i].i:=1+p(a[i],an2,z);
-  pxpy(an1,an,an2,z); for i:=0 to n do b^[i].j:=1+p(a[i],an1,z);
-  pxpy(an,an2,an1,z); for i:=0 to n do b^[i].k:=1+p(a[i],an,z);
-
-  e22[0].init(0,e(an1,an2),e(an,an2));
-  e22[1].init(e(an1,an2),0,e(an,an1));
-  e22[2].init(e(an,an2),e(an,an1),0);
-
-  for j:=0 to n do e21^[j].init(e(an2,a[j]),e(an1,a[j]),e(an,a[j]));
-
-  GetMem(c, (n+1)*SizeOf(pointer));
-  for j:=0 to n do GetMem(c^[j], (j+1)*SizeOf(ArbFloat));
-
-  for i:=0 to n do
-  for j:=0 to i do
-  begin
-    if j=i then s:=0 else s:=e(a[i],a[j]);
-    hulp.init(b^[j].Inprod(e22[0]), b^[j].Inprod(e22[1]), b^[j].Inprod(e22[2]));
-    hulp.sub(e21^[j]);
-    k^[i]^[j] := s+b^[i].InProd(hulp)-b^[j].Inprod(e21^[i]);
-    if j=i then s:=1/alfad[i].imag else s:=0;
-    hulp.init(b^[j].i/dv.i, b^[j].j/dv.j, b^[j].k/dv.k);
-    c^[i]^[j] := k^[i]^[j] + (s + b^[i].Inprod(hulp))/lambda
-  end;
-
-  for i:=0 to n do gamma[i]:=alfad[i].xreal - b^[i].Inprod(alfa);
-
-  SpdSol(n, pointer(c), gamma[0]);
-
-  for j:=n downto 0 do FreeMem(c^[j], (j+1)*SizeOf(ArbFloat));
-  FreeMem(c, (n+1)*SizeOf(pointer));
-
-  s:=0; for j:=0 to n do s:=s+b^[j].i*gamma[j]; w.i:=s; gamma[n+1] := -s;
-  s:=0; for j:=0 to n do s:=s+b^[j].j*gamma[j]; w.j:=s; gamma[n+2] := -s;
-  s:=0; for j:=0 to n do s:=s+b^[j].k*gamma[j]; w.k:=s; gamma[n+3] := -s;
-  FreeMem(b, (n+1)*SizeOf(vector));
-
-  u.init(w.i/dv.i, w.j/dv.j, w.k/dv.k);
-  u.scale(1/lambda);
-  u.add(alfa);
-
-  s:=0; for j:=0 to n do s:=s+e21^[j].i*gamma[j]; v.i := e22[0].inprod(w)-s;
-  s:=0; for j:=0 to n do s:=s+e21^[j].j*gamma[j]; v.j := e22[1].inprod(w)-s;
-  s:=0; for j:=0 to n do s:=s+e21^[j].k*gamma[j]; v.k := e22[2].inprod(w)-s;
-  FreeMem(e21, (n+1)*SizeOf(vector));
-
-  u.add(v);
-
-  pfxpfy(an2, an1, an, u, pf); u1:=u.i;
-
-  kwsom := 0; for j:=0 to n do kwsom:=kwsom+sqr(gamma[j])/alfad[j].imag;
-  kwsom := kwsom+sqr(w.i)/dv.i+sqr(w.j)/dv.j+sqr(w.k)/dv.k;
-  kwsom := kwsom/sqr(lambda);
-
-  s:=0;
-  for i:=0 to n do
-  begin s1:=0;
-        for j:=0 to i do s1:=s1+k^[i]^[j]*gamma[j];
-        for j:=i+1 to n do s1:=s1+k^[j]^[i]*gamma[j];
-        s := gamma[i]*s1+s
-  end;
-  for j:=n downto 0 do FreeMem(k^[j], (j+1)*SizeOf(ArbFloat));
-  FreeMem(k, (n+1)*SizeOf(pointer));
-  energie := s
-
-end {splineparameters};
-
-end.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:44  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:14  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/mdt.pas

@@ -1,970 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Unit was originally undocumented, but is probably an variant of DET.
-    Det accepts vectors as arguments, while MDT calculates determinants for
-    matrices.
-
-    Contrary to the other undocumented units, this unit is exported in the
-    DLL.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-Unit mdt;
-
-interface
-{$I DIRECT.INC}
-
-uses typ, dsl, omv;
-
-Procedure mdtgen(n, rwidth: ArbInt; Var alu: ArbFloat; Var p: ArbInt;
-                 Var ca:ArbFloat; Var term: ArbInt);
-
-Procedure mdtgtr(n: ArbInt; Var l, d, u, l1, d1, u1, u2: ArbFloat;
-                 Var p: boolean; Var ca: ArbFloat; Var term: ArbInt);
-
-Procedure mdtgsy(n, rwidth: ArbInt; Var a: ArbFloat; Var pp:ArbInt;
-                 Var qq:boolean; Var ca:ArbFloat; Var term:ArbInt);
-
-Procedure mdtgpd(n, rwidth: ArbInt; Var al, ca: ArbFloat; Var term: ArbInt);
-
-Procedure mdtgba(n, lb, rb, rwa: ArbInt; Var a: ArbFloat; rwl: ArbInt;
-                 Var l:ArbFloat; Var p: ArbInt; Var ca: ArbFloat; Var term:ArbInt);
-
-Procedure mdtgpb(n, lb, rwidth: ArbInt; Var al, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Procedure mdtdtr(n: ArbInt; Var l, d, u, l1, d1, u1: ArbFloat;
-                 Var term:ArbInt);
-
-implementation
-
-Procedure mdtgen(n, rwidth: ArbInt; Var alu: ArbFloat; Var p: ArbInt;
-                 Var ca:ArbFloat; Var term: ArbInt);
-
-Var 
-         indi, indk, nsr, ind, i, j, k, indexpivot : ArbInt;
-      normr, sumrowi, pivot, l, normt, maxim, h, s : ArbFloat;
-                                   palu, sumrow, t : ^arfloat1;
-                                                pp : ^arint1;
-                                          singular : boolean;
-Begin
-  If (n<1) Or (rwidth<1) Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  palu := @alu;
-  pp := @p;
-  nsr := n*sizeof(ArbFloat);
-  getmem(sumrow, nsr);
-  getmem(t, nsr);
-  normr := 0;
-  singular := false ;
-  For i:=1 To n Do
-    Begin
-      ind := (i-1)*rwidth;
-      pp^[i] := i;
-      sumrowi := 0;
-      For j:=1 To n Do
-        sumrowi := sumrowi+abs(palu^[ind+j]);
-      sumrow^[i] := sumrowi;
-     h := 2*random-1;
-     t^[i] := sumrowi*h;
-      h := abs(h);
-     If normr<h Then normr := h;
-      If sumrowi=0 Then
-        singular := true
-    End; {i}
-  For k:=1 To n Do
-    Begin
-      maxim := 0;
-     indexpivot := k;
-      For i:=k To n Do
-        Begin
-          ind := (i-1)*rwidth;
-          sumrowi := sumrow^[i];
-          If sumrowi <> 0 Then
-            Begin
-              h := abs(palu^[ind+k])/sumrowi;
-              If maxim<h Then
-                Begin
-                  maxim := h;
-                 indexpivot := i
-                End {maxim<h}
-            End {sumrow <> 0}
-        End; {i}
-      If maxim=0 Then
-        singular := true
-      Else
-        Begin
-          If indexpivot <> k Then
-            Begin
-              ind := (indexpivot-1)*rwidth;
-              indk := (k-1)*rwidth;
-              For j:=1 To n Do
-                Begin
-                  h := palu^[ind+j];
-                  palu^[ind+j] := palu^[indk+j];
-                  palu^[indk+j] := h
-                End; {j}
-              h := t^[indexpivot];
-             t^[indexpivot] := t^[k];
-              t^[k] := h;
-             pp^[k] := indexpivot;
-              sumrow^[indexpivot] := sumrow^[k]
-            End; {indexpivot <> k}
-          pivot := palu^[(k-1)*rwidth+k];
-          For i:=k+1 To n Do
-            Begin
-              ind := (i-1)*rwidth;
-              l := palu^[ind+k]/pivot;
-              palu^[ind+k] := l;
-              If l <> 0 Then
-                Begin
-                  For j:=k+1 To n Do
-                    palu^[ind+j] := palu^[ind+j]-l*palu^[(k-1)*rwidth+j];
-                  If Not singular Then
-                    t^[i] := t^[i]-l*t^[k]
-                End {l <> 0}
-            End {i}
-        End {maxim <> 0}
-    End; {k}
-    If Not singular Then
-      Begin
-        normt := 0;
-        For i:=n Downto 1 Do
-          Begin
-            indi := (i-1)*rwidth;
-            s := 0;
-            For j:=i+1 To n Do
-              s := s+t^[j]*palu^[indi+j];
-            t^[i] := (t^[i]-s)/palu^[indi+i];
-            h := abs(t^[i]);
-            If normt<h Then
-              normt := h
-          End; {i}
-        ca := normt/normr
-      End; {not singular}
-    If singular Then
-      Begin
-        term := 4;
-       ca := giant
-      End
-    Else
-      term := 1;
-  freemem(sumrow, nsr);
-  freemem(t, nsr)
-End; {mdtgen}
-
-Procedure mdtgtr(n: ArbInt; Var l, d, u, l1, d1, u1, u2: ArbFloat;
-                 Var p: boolean; Var ca: ArbFloat; Var term: ArbInt);
-
-Var 
-                         i, j, k, nmin1, sr : ArbInt;
-   normr, normt, sumrowi, h, lj, di, ui, ll : ArbFloat;
-                                       sing : boolean;
-           pd, pu, pd1, pu1, pu2, t, sumrow : ^arfloat1;
-                                    pl, pl1 : ^arfloat2;
-                                         pp : ^arbool1;
-Begin
-  If n<1 Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  pl := @l;
- pd := @d;
- pu := @u;
-  pl1 := @l1;
- pd1 := @d1;
- pu1 := @u1;
- pu2 := @u2;
- pp := @p;
-  sr := sizeof(ArbFloat);
-  move(pl^, pl1^, (n-1)*sr);
-  move(pd^, pd1^, n*sr);
-  move(pu^, pu1^, (n-1)*sr);
-  getmem(t, n*sr);
-  getmem(sumrow, n*sr);
-  normr := 0;
- sing := false;
-  nmin1 := n-1;
-  For i:=1 To n Do
-    Begin
-      pp^[i] := false;
-      If i=1 Then
-        sumrowi := abs(pd^[1])+abs(pu^[1])
-      Else
-        If i=n Then
-          sumrowi := abs(pl^[n])+abs(pd^[n])
-        Else
-          sumrowi := abs(pl^[i])+abs(pd^[i])+abs(pu^[i]);
-      sumrow^[i] := sumrowi;
-     h := 2*random-1;
-     t^[i] := sumrowi*h;
-      h := abs(h);
-      If normr<h Then
-        normr := h;
-      If sumrowi=0 Then
-        sing := true
-    End; {i}
-  j := 1;
-  while (j <> n) Do
-    Begin
-      i := j;
-     j := j+1;
-     lj := pl1^[j];
-      If lj <> 0 Then
-        Begin
-          di := pd1^[i];
-          If di=0 Then
-            pp^[i] := true
-          Else
-            pp^[i] := abs(di/sumrow^[i])<abs(lj/sumrow^[j]);
-          If pp^[i] Then
-            Begin
-              ui := pu1^[i];
-             pd1^[i] := lj;
-              pu1^[i] := pd1^[j];
-             pl1^[j] := di/lj;
-             ll := pl1^[j];
-              pd1^[j] := ui-ll*pd1^[j];
-              If i<nmin1 Then
-                Begin
-                  pu2^[i] := pu1^[j];
-                  pu1^[j] := -ll*pu2^[i]
-                End; {i<nmin1}
-              sumrow^[j] := sumrow^[i];
-              If (Not sing) Then
-                Begin
-                  h := t^[i];
-                 t^[i] := t^[j];
-                  t^[j] := h-ll*t^[i]
-                End {not sing}
-            End {pp^[i]}
-          Else
-            Begin
-              pl1^[j] := lj/di;
-             ll := pl1^[j];
-              pd1^[j] := pd1^[j]-ll*pu1^[i];
-              If i<nmin1 Then
-                pu2^[i] := 0;
-              If (Not sing) Then
-                t^[j] := t^[j]-ll*t^[i]
-            End {not pp^[i]}
-        End {lj<>0}
-      Else
-        Begin
-          If i<nmin1 Then
-            pu2^[i] := 0;
-          If pd1^[i]=0 Then
-            sing := true
-        End {lj=0}
-    End; {j}
-  If pd1^[n]=0 Then
-    sing := true;
-  If (Not sing) Then
-    Begin
-      normt := 0;
-      t^[n] := t^[n]/pd1^[n];
-      h := abs(t^[n]);
-      If normt<h Then
-        normt := h;
-      If n > 1 Then
-        Begin
-          t^[nmin1] := (t^[nmin1]-pu1^[nmin1]*t^[n])/pd1^[nmin1];
-          h := abs(t^[nmin1])
-        End; {n > 1}
-      If normt<h Then
-        normt := h;
-      For i:=n-2 Downto 1 Do
-        Begin
-          t^[i] := (t^[i]-pu1^[i]*t^[i+1]-pu2^[i]*t^[i+2])/pd1^[i];
-          h := abs(t^[i]);
-          If normt<h Then
-            normt := h
-        End; {i}
-      ca := normt/normr
-    End; {not sing}
-  If (sing) Then
-    Begin
-      term := 4;
-     ca := giant
-    End {sing}
-  Else
-    term := 1;
-  freemem(t, n*sr);
-  freemem(sumrow, n*sr)
-End; {mdtgtr}
-
-Procedure mdtgsy(n, rwidth: ArbInt; Var a: ArbFloat; Var pp:ArbInt;
-                 Var qq:boolean; Var ca:ArbFloat; Var term:ArbInt);
-
-Var 
-   i, j, kmin1, k, kplus1, kmin2, imin2, nsr, nsi, nsb, ii,
-   imin1, jmin1, indexpivot, iplus1, indi, indj, indk, indp       : ArbInt;
-   ra, h, absh, maxim, pivot, ct, norma, sumrowi, normt, normr, s : ArbFloat;
-                               alt, l, d, t, u, v, l1, d1, u1, t1 : ^arfloat1;
-                                                                p : ^arint1;
-                                                                q : ^arbool1;
-Begin
-  If (n<1) Or (rwidth<1) Then
-    Begin
-      term := 3;
-     exit
-    End; {if}
-  alt := @a;
- p := @pp;
- q := @qq;
-  nsr := n*sizeof(ArbFloat);
-  nsi := n*sizeof(ArbInt);
-  nsb := n*sizeof(boolean);
-  getmem(l, nsr);
-  getmem(d, nsr);
-  getmem(t, nsr);
-  getmem(u, nsr);
-  getmem(v, nsr);
-  getmem(l1, nsr);
-  getmem(d1, nsr);
-  getmem(u1, nsr);
-  getmem(t1, nsr);
-  norma := 0;
-  For i:=1 To n Do
-    Begin
-      indi := (i-1)*rwidth;
-      p^[i] := i;
-     sumrowi := 0;
-      For j:=1 To i Do
-        sumrowi := sumrowi+abs(alt^[indi+j]);
-      For j:=i+1 To n Do
-        sumrowi := sumrowi+abs(alt^[(j-1)*rwidth+i]);
-      If norma<sumrowi Then
-        norma := sumrowi
-    End; {i}
-  kmin1 := -1;
- k := 0;
- kplus1 := 1;
-  while k<n Do
-    Begin
-      kmin2 := kmin1;
-     kmin1 := k;
-     k := kplus1;
-     kplus1 := kplus1+1;
-      indk := kmin1*rwidth;
-      If k>3 Then
-        Begin
-          t^[2] := alt^[rwidth+2]*alt^[indk+1]+alt^[2*rwidth+2]*alt^[indk+2];
-          For i:=3 To kmin2 Do
-            Begin
-              indi := (i-1)*rwidth;
-              t^[i] := alt^[indi+i-1]*alt^[indk+i-2]+alt^[indi+i]
-                       *alt^[indk+i-1]+alt^[indi+rwidth+i]*alt^[indk+i]
-            End; {i}
-          t^[kmin1] := alt^[indk-rwidth+kmin2]*alt^[indk+k-3]
-                       +alt^[indk-rwidth+kmin1]*alt^[indk+kmin2]
-                       +alt^[indk+kmin1];
-          h := alt^[indk+k];
-          For j:=2 To kmin1 Do
-            h := h-t^[j]*alt^[indk+j-1];
-          t^[k] := h;
-          alt^[indk+k] := h-alt^[indk+kmin1]*alt^[indk+kmin2]
-        End {k>3}
-      Else
-       If k=3 Then
-        Begin
-          t^[2] := alt^[rwidth+2]*alt^[2*rwidth+1]+alt^[2*rwidth+2];
-          h := alt^[2*rwidth+3]-t^[2]*alt^[2*rwidth+1];
-          t^[3] := h;
-          alt^[2*rwidth+3] := h-alt^[2*rwidth+2]*alt^[2*rwidth+1]
-        End  {k=3}
-      Else
-       If k=2 Then
-        t^[2] := alt^[rwidth+2];
-      maxim := 0;
-      For i:=kplus1 To n Do
-        Begin
-          indi := (i-1)*rwidth;
-          h := alt^[indi+k];
-          For j:=2 To k Do
-            h := h-t^[j]*alt^[indi+j-1];
-          absh := abs(h);
-          If maxim<absh Then
-            Begin
-              maxim := absh;
-             indexpivot := i
-            End; {if}
-          alt^[indi+k] := h
-        End; {i}
-      If maxim <> 0 Then
-        Begin
-          If indexpivot>kplus1 Then
-            Begin
-              indp := (indexpivot-1)*rwidth;
-              indk := k*rwidth;
-              p^[kplus1] := indexpivot;
-              For j:=1 To k Do
-                Begin
-                  h := alt^[indk+j];
-                  alt^[indk+j] := alt^[indp+j];
-                  alt^[indp+j] := h
-                End; {j}
-              For j:=indexpivot Downto kplus1 Do
-                Begin
-                  indj := (j-1)*rwidth;
-                  h := alt^[indj+kplus1];
-                  alt^[indj+kplus1] := alt^[indp+j];
-                  alt^[indp+j] := h
-                End; {j}
-              For i:=indexpivot To n Do
-                Begin
-                  indi := (i-1)*rwidth;
-                  h := alt^[indi+kplus1];
-                  alt^[indi+kplus1] := alt^[indi+indexpivot];
-                  alt^[indi+indexpivot] := h
-                End  {i}
-            End; {if}
-          pivot := alt^[k*rwidth+k];
-          For i:=k+2 To n Do
-            alt^[(i-1)*rwidth+k] := alt^[(i-1)*rwidth+k]/pivot
-        End {maxim <> 0}
-    End; {k}
-  d^[1] := alt^[1];
- i := 1;
-  while i<n Do
-    Begin
-      imin1 := i;
-     i := i+1;
-      u^[imin1] := alt^[(i-1)*rwidth+imin1];
-      l^[imin1] := u^[imin1];
-     d^[i] := alt^[(i-1)*rwidth+i]
-    End; {i}
-  mdtgtr(n, l^[1], d^[1], u^[1], l1^[1], d1^[1], u1^[1], v^[1],
-         q^[1], ct, term);
-  alt^[1] := d1^[1];
- alt^[rwidth+1] := l1^[1];
-  alt^[rwidth+2] := d1^[2];
- alt^[2] := u1^[1];
-  imin1 := 1;
- i := 2;
-  while i<n Do
-    Begin
-      imin2 := imin1;
-     imin1 := i;
-     i := i+1;
-      indi := imin1*rwidth;
-      alt^[indi+imin1] := l1^[imin1];
-     alt^[indi+i] := d1^[i];
-      alt^[(imin1-1)*rwidth+i] := u1^[imin1];
-      alt^[(imin2-1)*rwidth+i] := v^[imin2]
-    End; {i}
-  If term=1 Then
-    Begin
-      normr := 0;
-      For i:=1 To n Do
-        Begin
-          t^[i] := 2*random-1;
-         h := t^[i];
-          h := abs(h);
-          If normr<h Then
-            normr := h
-        End; {i}
-      i := 0;
-      while i<n Do
-        Begin
-          imin1 := i;
-         i := i+1;
-         j := 1;
-         h := t^[i];
-          while j<imin1 Do
-            Begin
-              jmin1 := j;
-             j := j+1;
-              h := h-alt^[(i-1)*rwidth+jmin1]*t^[j]
-            End; {j}
-          t^[i] := h
-        End; {i}
-      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], t^[1], t1^[1], term);
-      i := n+1;
-     imin1 := n;
-     normt := 0;
-      while i>2 Do
-        Begin
-          iplus1 := i;
-         i := imin1;
-         imin1 := imin1-1;
-         h := t1^[i];
-          For j:=iplus1 To n Do
-            h := h-alt^[(j-1)*rwidth+imin1]*t1^[j];
-          t1^[i] := h;
-         h := abs(h);
-          If normt<h Then
-            normt := h
-        End; {i}
-      ca := norma*normt/normr
-    End {term=1}
-  Else ca := giant;
-  freemem(l, nsr);
-  freemem(d, nsr);
-  freemem(t, nsr);
-  freemem(u, nsr);
-  freemem(v, nsr);
-  freemem(l1, nsr);
-  freemem(d1, nsr);
-  freemem(u1, nsr);
-  freemem(t1, nsr)
-End; {mdtgsy}
-
-Procedure mdtgpd(n, rwidth: ArbInt; Var al, ca: ArbFloat; Var term: ArbInt);
-
-Var 
-    posdef                               : boolean;
-    i, j, k, kmin1, indk, indi           : ArbInt;
-    h, lkk, normr, normt, sumrowi, norma : ArbFloat;
-    pal, t                               : ^arfloat1;
-Begin
-  If (n<1) Or (rwidth<1) Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  getmem(t, sizeof(ArbFloat)*n);
-  pal := @al;
-  normr := 0;
-  posdef := true;
-  norma := 0;
-  For i:=1 To n Do
-    Begin
-      sumrowi := 0;
-      For j:=1 To i Do
-        sumrowi := sumrowi+abs(pal^[(i-1)*rwidth+j]);
-      For j:=i+1 To n Do
-        sumrowi := sumrowi+abs(pal^[(j-1)*rwidth+i]);
-      If norma<sumrowi Then
-        norma := sumrowi;
-      t^[i] := 2*random-1;
-     h := t^[i];
-      h := abs(h);
-      If normr<h Then
-        normr := h
-    End; {i}
-  k := 0;
-  while (k<n) and posdef Do
-    Begin
-      kmin1 := k;
-     k := k+1;
-      indk := (k-1)*rwidth;
-      lkk := pal^[indk+k];
-      For j:=1 To kmin1 Do
-        lkk := lkk-sqr(pal^[indk+j]);
-      If lkk <= 0 Then
-        posdef := false
-      Else
-        Begin
-          pal^[indk+k] := sqrt(lkk);
-         lkk := pal^[indk+k];
-          For i:=k+1 To n Do
-            Begin
-              indi := (i-1)*rwidth;
-              h := pal^[indi+k];
-              For j:=1 To kmin1 Do
-                h := h-pal^[indk+j]*pal^[indi+j];
-              pal^[indi+k] := h/lkk
-            End; {i}
-          h := t^[k];
-          For j:=1 To kmin1 Do
-            h := h-pal^[indk+j]*t^[j];
-          t^[k] := h/lkk
-        End {posdef}
-    End; {k}
-  If posdef Then
-    Begin
-      normt := 0;
-      For i:=n Downto 1 Do
-        Begin
-          h := t^[i];
-          For j:=i+1 To n Do
-            h := h-pal^[(j-1)*rwidth+i]*t^[j];
-          t^[i] := h/pal^[(i-1)*rwidth+i];
-          h := abs(t^[i]);
-          If normt<h Then
-            normt := h
-        End; {i}
-      ca := norma*normt/normr
-    End; {posdef}
-  If posdef Then
-    term := 1
-  Else
-    term := 2;
-  freemem(t, sizeof(ArbFloat)*n);
-End; {mdtgpd}
-
-Procedure mdtgba(n, lb, rb, rwa: ArbInt; Var a: ArbFloat; rwl: ArbInt;
-                 Var l:ArbFloat; Var p: ArbInt; Var ca: ArbFloat; Var term:ArbInt);
-
-Var
-  sr, i, j, k, ipivot, m, lbj, lbi, ubi, ls,
-             ii, jj, ll, s, js, jl, ubj       : ArbInt;
-  ra, normr, sumrowi, pivot, normt, maxim, h  : ArbFloat;
-          pl, au, sumrow, t, row              : ^arfloat1;
-                                           pp : ^arint1;
-
-Begin
-  If (n<1) Or (lb<0) Or (rb<0) Or (lb>n-1) Or (rb>n-1) Or (rwl<0) Or (rwa<1) Then
-    Begin
-      term := 3;
-     exit
-    End; {term=3}
-  sr := sizeof(ArbFloat);
-  au := @a;
-  pl := @l;
-  pp := @p;
-  ll := lb+rb+1;
-  ls := ll*sr;
-  getmem(sumrow, n*sr);
-  getmem(t, n*sr);
-  getmem(row, ls);
-  lbi := n-rb+1;
- lbj := 0;
-  jj := 1;
-  For i:=lb Downto 1 Do
-    Begin
-      move(au^[i+jj], au^[jj], (ll-i)*sr);
-      fillchar(au^[jj+ll-i], i*sr, 0);
-      jj := jj+rwa
-    End; {i}
-  jj := (n-rb)*rwa+ll;
-  For i:=1 To rb Do
-    Begin
-      fillchar(au^[jj], i*sr, 0);
-      jj := jj+rwa-1
-    End; {i}
-  normr := 0;
- term := 1;
-  ii := 1;
-  For i:=1 To n Do
-    Begin
-      pp^[i] := i;
-      sumrowi := omvn1v(au^[ii], ll);
-      ii := ii+rwa;
-      sumrow^[i] := sumrowi;
-      h := 2*random-1;
-     t^[i] := sumrowi*h;
-      h := abs(h);
-      If normr<h Then
-        normr := h;
-      If sumrowi=0 Then
-        term := 4
-    End; {i}
-  ubi := lb;
-  jj := 1;
-  For k:=1 To n Do
-    Begin
-     maxim := 0;
-     ipivot := k;
-     ii := jj;
-      If ubi<n Then
-        ubi := ubi+1;
-      For i:=k To ubi Do
-        Begin
-          sumrowi := sumrow^[i];
-          If sumrowi <> 0 Then
-            Begin
-              h := abs(au^[ii])/sumrowi;
-              ii := ii+rwa;
-              If maxim<h Then
-                Begin
-                  maxim := h;
-                 ipivot := i
-                End {maxim<h}
-            End {sumrowi <> 0}
-        End; {i}
-      If maxim=0 Then
-        Begin
-          lbj := 1;
-         ubj := ubi-k;
-          For j:=lbj To ubj Do
-            pl^[(k-1)*rwl+j] := 0;
-          For i:=k+1 To ubi Do
-            Begin
-              ii := (i-1)*rwa;
-              For j:=2 To ll Do
-                au^[ii+j-1] := au^[ii+j];
-              au^[ii+ll] := 0
-            End; {i}
-          term := 4
-        End {maxim=0}
-      Else
-        Begin
-          If ipivot <> k Then
-            Begin
-              ii := (ipivot-1)*rwa+1;
-              move(au^[ii], row^, ls);
-              move(au^[jj], au^[ii], ls);
-              move(row^, au^[jj], ls);
-              h := t^[ipivot];
-              t^[ipivot] := t^[k];
-              t^[k] := h;
-              pp^[k] := ipivot;
-              sumrow^[ipivot] := sumrow^[k]
-            End; {ipivot <> k}
-          pivot := au^[jj];
-          jl := 0;
-          ii := jj;
-          For i:=k+1 To ubi Do
-            Begin
-              jl := jl+1;
-              ii := ii+rwa;
-              h := au^[ii]/pivot;
-              pl^[(k-1)*rwl+jl] := h;
-              For j:=0 To ll-2 Do
-                au^[ii+j] := au^[ii+j+1]-h*au^[jj+j+1];
-              au^[ii+ll-1] := 0;
-              If term=1 Then
-                t^[i] := t^[i]-h*t^[k]
-            End {i}
-        End; {maxim <> 0}
-      jj := jj+rwa
-    End; {k}
-  If term=1 Then
-    Begin
-      normt := 0;
-      ubj := -lb-1;
-      jj := n*rwa+1;
-      For i:=n Downto 1 Do
-        Begin
-          jj := jj-rwa;
-          If ubj<rb Then
-            ubj := ubj+1;
-          h := t^[i];
-          For j:=1 To ubj+lb Do
-            h := h-au^[jj+j]*t^[i+j];
-          t^[i] := h/au^[jj];
-          h := abs(t^[i]);
-          If normt<h Then
-            normt := h
-        End; {i}
-      ca := normt/normr
-    End {term=1}
-  Else
-   ca := giant;
-  freemem(sumrow, n*sr);
-  freemem(t, n*sr);
-  freemem(row, ls)
-End; {mdtgba}
-
-Procedure mdtgpb(n, lb, rwidth: ArbInt; Var al, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Var 
-    posdef                                           : boolean;
-    i, j, k, r, p, q, ll, llmin1, jmin1, indi        : ArbInt;
-    h, normr, normt, sumrowi, alim, norma            : ArbFloat;
-    pal, t                                           : ^arfloat1;
-
-    Procedure decomp(i, r: ArbInt);
-
-    Var 
-        k, ii, ir : ArbInt;
-    Begin
-      ii := (i-1)*rwidth;
-      ir := (r-1)*rwidth;
-      h := pal^[ii+j];
-     q := ll-j+p;
-      For k:=p To jmin1 Do
-        Begin
-          h := h-pal^[ii+k]*pal^[ir+q];
-         q := q+1
-        End; {k}
-      If j<ll Then
-        pal^[ii+j] := h/pal^[ir+ll]
-    End; {decomp}
-
-    Procedure lmin1t(i: ArbInt);
-
-    Var 
-        k:ArbInt;
-    Begin
-      h := t^[i];
-     q := i;
-      For k:=llmin1 Downto p Do
-        Begin
-          q := q-1;
-         h := h-pal^[indi+k]*t^[q]
-        End; {k}
-      t^[i] := h/alim
-    End; {lmin1t}
-
-Begin
-  If (lb<0) Or (lb>n-1) Or (n<1) Or (rwidth<1) Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  pal := @al;
-  getmem(t, n*sizeof(ArbFloat));
-  ll := lb+1;
- normr := 0;
- p := ll+1;
- norma := 0;
-  For i:=1 To n Do
-    Begin
-      If p>1 Then
-        p := p-1;
-      indi := (i-1)*rwidth+p;
-      sumrowi := omvn1v(pal^[indi], ll-p+1);
-      r := i;
-     j := ll;
-      while (r<n) and (j>1) Do
-        Begin
-          r := r+1;
-         j := j-1;
-          sumrowi := sumrowi+abs(pal^[(r-1)*rwidth+j])
-        End; {r,j}
-      If norma<sumrowi Then
-        norma := sumrowi;
-      h := 2*random-1;
-     t^[i] := h;
-      h := abs(h);
-      If normr<h Then
-        normr := h
-    End; {i}
-    llmin1 := ll-1;
-    p := ll+1;
-    i := 0;
-    posdef := true ;
-    while (i<n) and posdef Do
-      Begin
-        i := i+1;
-        indi := (i-1)*rwidth;
-        If p>1 Then
-          p := p-1;
-        r := i-ll+p;
-       j := p-1;
-        while j<llmin1 Do
-          Begin
-            jmin1 := j;
-           j := j+1;
-            decomp(i, r);
-           r := r+1
-          End; {j}
-        jmin1 := llmin1;
-       j := ll;
-       decomp(i, i);
-        If h <= 0 Then
-          posdef := false
-        Else
-          Begin
-            alim := sqrt(h);
-           pal^[indi+ll] := alim;
-            lmin1t(i)
-          End
-      End; {i}
-    If posdef Then
-      Begin
-        normt := 0;
-       p := ll+1;
-        For i:=n Downto 1 Do
-          Begin
-            If p>1 Then
-              p := p-1;
-            q := i;
-           h := t^[i];
-            For k:=llmin1 Downto p Do
-              Begin
-                q := q+1;
-               h := h-pal^[(q-1)*rwidth+k]*t^[q]
-              End; {k}
-            t^[i] := h/pal^[(i-1)*rwidth+ll];
-            h := abs(t^[i]);
-            If normt<h Then
-              normt := h
-          End; {i}
-        ca := norma*normt/normr
-      End; {posdef}
-    If posdef Then
-      term := 1
-    Else
-      term := 2;
-  freemem(t, n*sizeof(ArbFloat));
-End; {mdtgpb}
-
-Procedure mdtdtr(n: ArbInt; Var l, d, u, l1, d1, u1: ArbFloat;
-                 Var term:ArbInt);
-
-Var
-                      i, j, s : ArbInt;
-                       lj, di : ArbFloat;
-             pd, pu, pd1, pu1 : ^arfloat1;
-                      pl, pl1 : ^arfloat2;
-
-Begin
-  If n<1 Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  pl := @l;
-  pd := @d;
-  pu := @u;
-  pl1 := @l1;
-  pd1 := @d1;
-  pu1 := @u1;
-  s := sizeof(ArbFloat);
-  move(pl^, pl1^, (n-1)*s);
-  move(pd^, pd1^, n*s);
-  move(pu^, pu1^, (n-1)*s);
-  j := 1;
-  di := pd1^[j];
-  If di=0 Then
-    term := 2
-  Else
-    term := 1;
-  while (term=1) and (j <> n) Do
-    Begin
-     i := j;
-     j := j+1;
-     lj := pl1^[j]/di;
-     pl1^[j] := lj;
-     di := pd1^[j]-lj*pu1^[i];
-     pd1^[j] := di;
-     If di=0 Then
-      term := 2
-    End {j}
-End; {mdtdtr}
-
-Begin
-  randseed := 12345
-End.
-
-{
-  $Log$
-  Revision 1.2.2.1  2002-01-16 14:57:44  florian
-  no message
-
-  Revision 1.2  2002/01/16 14:47:16  florian
-    + Makefile.fpc added
-    * several small changes to get things running with FPC 1.0.x
-
-  Revision 1.1  2000/07/13 06:34:15  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-}

packages/numlib/numlib.pas

@@ -1,323 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             Documentation by Michael van Canneyt ([email protected])
-
-    This unit exports all functions in the tpnumlib dll. (a header file more
-    or less) Programs based on this unit don't require the other sources to
-    compile/build, only the DLL, direct.inc and this file are needed.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-unit NumLib;
-
-interface
-{$I direct.inc}
-
-uses typ;
-
-CONST Numlib_dll_version=2;        {Original is 1, first FPC version=2}
-
-{not wrapped to 80 columns yet, since this is easier for copying and
-pasting, and adding of the external lines}
-
-{Added; if the internal version of this unit and dll differ,
-this function returns FALSE, and program can abort}
-FUNCTION CheckVersion: BOOLEAN;
-
-procedure detgen(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure detgsy(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure detgpd(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure detgba(n, l, r: ArbInt; var a, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure detgpb(n, l: ArbInt; var a, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure detgtr(n: ArbInt; var l, d, u, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure dslgen(n, rwidth: ArbInt; var alu: ArbFloat; var p: ArbInt;var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure dslgtr(n: ArbInt; var l1, d1, u1, u2: ArbFloat; var p: boolean; var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure dslgsy(n, rwidth: ArbInt; var alt: ArbFloat; var p: ArbInt;var q: boolean; var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure dslgpd(n, rwidth: ArbInt; var al, b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure dslgba(n, lb, rb, rwa: ArbInt; var au: ArbFloat; rwl: ArbInt;var l: ArbFloat; var p: ArbInt; var b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure dslgpb(n, lb, rwidth: ArbInt; var al, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure dsldtr(n:ArbInt; var l, d, u, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eiggs1(var a: ArbFloat; n, rwidth: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eiggs2(var a: ArbFloat; n, rwidth, k1, k2: ArbInt;var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eiggs3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eiggs4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigts1(var d, cd: ArbFloat; n: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigts2(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigts3(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;rwidth: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigts4(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam, x: ArbFloat;rwidth: ArbInt; var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigbs1(var a: ArbFloat; n, l: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigbs2(var a: ArbFloat; n, l, k1, k2: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigbs3(var a: ArbFloat; n, l: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigbs4(var a: ArbFloat; n, l, k1, k2: ArbInt;var lam, x: ArbFloat;  rwidthx: ArbInt;var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigge1(var a: ArbFloat; n, rwidth: ArbInt; var lam: complex;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigge3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: complex;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eiggg1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eiggg2(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eiggg3(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eiggg4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigsv1(var a: ArbFloat; m, n, rwidth: ArbInt; var sig: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure eigsv3(var a: ArbFloat; m, n, rwidtha: ArbInt; var sig, u: ArbFloat;rwidthu: ArbInt; var v: ArbFloat; rwidthv: ArbInt;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure int1fr(f: rfunc1r; a, b, ae: ArbFloat; var integral, err: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure invgen(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure invgsy(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure invgpd(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure iomrev(var inp: text; var v: ArbFloat; n: ArbInt);
-procedure iomrem(var inp: text; var a: ArbFloat; m, n, rwidth: ArbInt);
-procedure iomwrv(var out: text; var v: ArbFloat; n, form: ArbInt);
-procedure iomwrm(var out: text; var a: ArbFloat; m, n, rwidth, form: ArbInt);
-procedure mdtgen(n, rwidth: ArbInt; var alu: ArbFloat; var p: ArbInt;var ca:ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure mdtgtr(n: ArbInt; var l, d, u, l1, d1, u1, u2: ArbFloat; var p: boolean; var ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure mdtgsy(n, rwidth: ArbInt; var a: ArbFloat; var pp:ArbInt;var qq:boolean; var ca:ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure mdtgpd(n, rwidth: ArbInt; var al, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure mdtgba(n, lb, rb, rwa: ArbInt; var a: ArbFloat; rwl: ArbInt;var l:ArbFloat; var p: ArbInt; var ca: ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure mdtgpb(n, lb, rwidth: ArbInt; var al, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure mdtdtr(n: ArbInt; var l, d, u, l1, d1, u1: ArbFloat;var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure odeiv1(f: rfunc2r; a, ya: ArbFloat; var b, yb: ArbFloat;ae: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure odeiv2(f: oderk1n; a: ArbFloat; var ya, b, yb: ArbFloat;n: ArbInt; ae: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function omvinp(var a, b: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure omvmmm(var a: ArbFloat; m, n, rwa: ArbInt;var b: ArbFloat; k, rwb: ArbInt;var c: ArbFloat; rwc: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure omvmmv(var a: ArbFloat; m, n, rwidth: ArbInt; var b, c: ArbFloat); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function omvn1m(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function omvn1v(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function omvn2v(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function omvnfm(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function omvnmm(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function omvnmv(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure omvtrm(var a: ArbFloat; m, n, rwa: ArbInt;var c: ArbFloat; rwc: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure roobin(n: ArbInt; a: complex; var z: complex; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure roof1r(f: rfunc1r; a, b, ae, re: ArbFloat; var x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure roopol(var a: ArbFloat; n: ArbInt; var z: complex;var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure rooqua(p, q: ArbFloat; var z1, z2: complex); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure roofnr(f: roofnrfunc; n: ArbInt; var x, residu: ArbFloat; re: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure sledtr(n: ArbInt; var l, d, u, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegba(n, l, r: ArbInt;var a, b, x, ca: ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegbal(n, l, r: ArbInt;var a1; var b1, x1, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegen(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegenl(n: ArbInt;var a1;var b1, x1, ca: ArbFloat;                  var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegls(var a: ArbFloat; m, n, rwidtha: ArbInt; var b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure sleglsl(var a1; m, n: ArbInt; var b1, x1: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegpb(n, l: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegpbl(n, l: ArbInt;var a1; var b1, x1, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegpd(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegpdl(n: ArbInt; var a1; var b1, x1, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegsy(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegsyl(n: ArbInt; var a1; var b1, x1, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure slegtr(n:ArbInt; var l, d, u, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function spebi0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
-function spebi1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
-function spebj0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
-function spebj1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
-function spebk0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
-function spebk1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
-function speby0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
-function speby1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
-function speent(x: ArbFloat): longint; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}
-function speerf(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}
-function speefc(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}
-function spegam(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}
-function spelga(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 20 oktober 1993}
-function spemax(a, b: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}
-function spepol(x: ArbFloat; var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}
-function spepow(a, b: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}
-function spesgn(x: ArbFloat): ArbInt; {ok 26 oktober 1993}
-function spears(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 21 oktober 1993}
-function spearc(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 21 oktober 1993}
-function spesih(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
-function specoh(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
-function spetah(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
-function speash(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
-function speach(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
-function speath(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
-function  spl1bspv(q: ArbInt; var kmin1, c1: ArbFloat; x: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function  spl2bspv(qx, qy: ArbInt; var kxmin1, kymin1, c11: ArbFloat; x, y: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure spl1bspf(M, Q: ArbInt; var XYW1: ArbFloat;var Kmin1, C1, residu: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure spl2bspf(M, Qx, Qy: ArbInt; var XYZW1: ArbFloat;var Kxmin1, Kymin1, C11, residu: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure spl1nati(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure spl1naki(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure spl1cmpi(n: ArbInt; var xyc1: ArbFloat; dy1, dyn: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure spl1peri(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function  spl1pprv(n: ArbInt; var xyc1: ArbFloat; t: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure spl1nalf(n: ArbInt; var xyw1: ArbFloat; lambda:ArbFloat;var xac1, residu: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function spl2natv(n: ArbInt; var xyg0: ArbFloat; u, v: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure spl2nalf(n: ArbInt; var xyzw1: ArbFloat; lambda:ArbFloat;var xyg0, residu: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-//procedure Intsle(l: ArbInt; e: ArbFloat); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function dllversion:LONGINT; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function exp(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function MachCnst(n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure ipffsn(n: ArbInt; var x, y, a, d2a: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure ipfisn(n: ArbInt; var x, y, d2s: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function  ipfspn(n: ArbInt; var x, y, d2s: ArbFloat; t: ArbFloat;var term: ArbInt): ArbFloat;{$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure ipfpol(m, n: ArbInt; var x, y, b: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}
-function spline(n: ArbInt; x: complex; var ac: complex; var gammar: ArbFloat; u1: ArbFloat; pf: complex): ArbFloat;{$IFDEF Needsstdcall} stdcall; {$ENDIF}
-procedure splineparameters (n: ArbInt; var ac, alfadc: complex; var lambda, gammar, u1, kwsom, energie: ArbFloat; var pf: complex);{$IFDEF Needsstdcall} stdcall; {$ENDIF}
-
-implementation
-
-
-procedure detgen(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   1;
-procedure detgsy(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   2;
-procedure detgpd(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   3;
-procedure detgba(n, l, r: ArbInt; var a, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                external 'TpNumLib'  index   4;
-procedure detgpb(n, l: ArbInt; var a, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                   external 'TpNumLib'  index   5;
-procedure detgtr(n: ArbInt; var l, d, u, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                external 'TpNumLib'  index   6;
-procedure dslgen(n, rwidth: ArbInt; var alu: ArbFloat; var p: ArbInt;var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                               external 'TpNumLib'  index   7;
-procedure dslgtr(n: ArbInt; var l1, d1, u1, u2: ArbFloat; var p: boolean; var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                          external 'TpNumLib'  index   8;
-procedure dslgsy(n, rwidth: ArbInt; var alt: ArbFloat; var p: ArbInt;var q: boolean; var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                               external 'TpNumLib'  index   9;
-procedure dslgpd(n, rwidth: ArbInt; var al, b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   10;
-procedure dslgba(n, lb, rb, rwa: ArbInt; var au: ArbFloat; rwl: ArbInt;var l: ArbFloat; var p: ArbInt; var b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}              external 'TpNumLib'  index   11;
-procedure dslgpb(n, lb, rwidth: ArbInt; var al, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                        external 'TpNumLib'  index   12;
-procedure dsldtr(n:ArbInt; var l, d, u, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                external 'TpNumLib'  index   13;
-procedure eiggs1(var a: ArbFloat; n, rwidth: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                external 'TpNumLib'  index   14;
-procedure eiggs2(var a: ArbFloat; n, rwidth, k1, k2: ArbInt;var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                         external 'TpNumLib'  index   15;
-procedure eiggs3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                            external 'TpNumLib'  index   16;
-procedure eiggs4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                external 'TpNumLib'  index   17;
-procedure eigts1(var d, cd: ArbFloat; n: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                     external 'TpNumLib'  index   18;
-procedure eigts2(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                             external 'TpNumLib'  index   19;
-procedure eigts3(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;rwidth: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                  external 'TpNumLib'  index   20;
-procedure eigts4(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam, x: ArbFloat;rwidth: ArbInt; var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                      external 'TpNumLib'  index   21;
-procedure eigbs1(var a: ArbFloat; n, l: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                      external 'TpNumLib'  index   22;
-procedure eigbs2(var a: ArbFloat; n, l, k1, k2: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                              external 'TpNumLib'  index   23;
-procedure eigbs3(var a: ArbFloat; n, l: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                  external 'TpNumLib'  index   24;
-procedure eigbs4(var a: ArbFloat; n, l, k1, k2: ArbInt;var lam, x: ArbFloat;  rwidthx: ArbInt;var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                      external 'TpNumLib'  index   25;
-procedure eigge1(var a: ArbFloat; n, rwidth: ArbInt; var lam: complex;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                  external 'TpNumLib'  index   26;
-procedure eigge3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: complex;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                             external 'TpNumLib'  index   27;
-procedure eiggg1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                              external 'TpNumLib'  index   28;
-procedure eiggg2(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                      external 'TpNumLib'  index   29;
-procedure eiggg3(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}           external 'TpNumLib'  index   30;
-procedure eiggg4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}external 'TpNumLib'  index   31;
-procedure eigsv1(var a: ArbFloat; m, n, rwidth: ArbInt; var sig: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                              external 'TpNumLib'  index   32;
-procedure eigsv3(var a: ArbFloat; m, n, rwidtha: ArbInt; var sig, u: ArbFloat;rwidthu: ArbInt; var v: ArbFloat; rwidthv: ArbInt;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}        external 'TpNumLib'  index   33;
-procedure int1fr(f: rfunc1r; a, b, ae: ArbFloat; var integral, err: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                           external 'TpNumLib'  index   34;
-procedure invgen(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                  external 'TpNumLib'  index   35;
-procedure invgsy(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                  external 'TpNumLib'  index   36;
-procedure invgpd(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                  external 'TpNumLib'  index   37;
-procedure iomrev(var inp: text; var v: ArbFloat; n: ArbInt);                                                                                                                                      external 'TpNumLib'  index   38;
-procedure iomrem(var inp: text; var a: ArbFloat; m, n, rwidth: ArbInt);                                                                                                                           external 'TpNumLib'  index   39;
-procedure iomwrv(var out: text; var v: ArbFloat; n, form: ArbInt);                                                                                                                                external 'TpNumLib'  index   40;
-procedure iomwrm(var out: text; var a: ArbFloat; m, n, rwidth, form: ArbInt);                                                                                                                     external 'TpNumLib'  index   41;
-procedure mdtgen(n, rwidth: ArbInt; var alu: ArbFloat; var p: ArbInt;var ca:ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                  external 'TpNumLib'  index   42;
-procedure mdtgtr(n: ArbInt; var l, d, u, l1, d1, u1, u2: ArbFloat; var p: boolean; var ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                   external 'TpNumLib'  index   43;
-procedure mdtgsy(n, rwidth: ArbInt; var a: ArbFloat; var pp:ArbInt;var qq:boolean; var ca:ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                     external 'TpNumLib'  index   44;
-procedure mdtgpd(n, rwidth: ArbInt; var al, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                              external 'TpNumLib'  index   45;
-procedure mdtgba(n, lb, rb, rwa: ArbInt; var a: ArbFloat; rwl: ArbInt;var l:ArbFloat; var p: ArbInt; var ca: ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                  external 'TpNumLib'  index   46;
-procedure mdtgpb(n, lb, rwidth: ArbInt; var al, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                           external 'TpNumLib'  index   47;
-procedure mdtdtr(n: ArbInt; var l, d, u, l1, d1, u1: ArbFloat;var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                           external 'TpNumLib'  index   48;
-procedure odeiv1(f: rfunc2r; a, ya: ArbFloat; var b, yb: ArbFloat;ae: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                        external 'TpNumLib'  index   49;
-procedure odeiv2(f: oderk1n; a: ArbFloat; var ya, b, yb: ArbFloat;n: ArbInt; ae: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                             external 'TpNumLib'  index   50;
-function omvinp(var a, b: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                 external 'TpNumLib'  index   51;
-procedure omvmmm(var a: ArbFloat; m, n, rwa: ArbInt;var b: ArbFloat; k, rwb: ArbInt;var c: ArbFloat; rwc: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                        external 'TpNumLib'  index   52;
-procedure omvmmv(var a: ArbFloat; m, n, rwidth: ArbInt; var b, c: ArbFloat); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                              external 'TpNumLib'  index   53;
-function omvn1m(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                         external 'TpNumLib'  index   54;
-function omvn1v(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                    external 'TpNumLib'  index   55;
-function omvn2v(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                    external 'TpNumLib'  index   56;
-function omvnfm(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                         external 'TpNumLib'  index   57;
-function omvnmm(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                         external 'TpNumLib'  index   58;
-function omvnmv(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                    external 'TpNumLib'  index   59;
-procedure omvtrm(var a: ArbFloat; m, n, rwa: ArbInt;var c: ArbFloat; rwc: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                        external 'TpNumLib'  index   60;
-procedure roobin(n: ArbInt; a: complex; var z: complex; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                external 'TpNumLib'  index   61;
-procedure roof1r(f: rfunc1r; a, b, ae, re: ArbFloat; var x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                   external 'TpNumLib'  index   62;
-procedure roopol(var a: ArbFloat; n: ArbInt; var z: complex;var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                         external 'TpNumLib'  index   63;
-procedure rooqua(p, q: ArbFloat; var z1, z2: complex); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                    external 'TpNumLib'  index   64;
-procedure roofnr(f: roofnrfunc; n: ArbInt; var x, residu: ArbFloat; re: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                       external 'TpNumLib'  index   65;
-procedure sledtr(n: ArbInt; var l, d, u, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                               external 'TpNumLib'  index   66;
-procedure slegba(n, l, r: ArbInt;var a, b, x, ca: ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   67;
-procedure slegbal(n, l, r: ArbInt;var a1; var b1, x1, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                    external 'TpNumLib'  index   68;
-procedure slegen(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   69;
-procedure slegenl(n: ArbInt;var a1;var b1, x1, ca: ArbFloat;                  var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                          external 'TpNumLib'  index   70;
-procedure slegls(var a: ArbFloat; m, n, rwidtha: ArbInt; var b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                            external 'TpNumLib'  index   71;
-procedure sleglsl(var a1; m, n: ArbInt; var b1, x1: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                           external 'TpNumLib'  index   72;
-procedure slegpb(n, l: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                               external 'TpNumLib'  index   73;
-procedure slegpbl(n, l: ArbInt;var a1; var b1, x1, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                       external 'TpNumLib'  index   74;
-procedure slegpd(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   75;
-procedure slegpdl(n: ArbInt; var a1; var b1, x1, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   76;
-procedure slegsy(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   77;
-procedure slegsyl(n: ArbInt; var a1; var b1, x1, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   78;
-procedure slegtr(n:ArbInt; var l, d, u, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   79;
-function spebi0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   80;
-function spebi1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   81;
-function spebj0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   82;
-function spebj1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   83;
-function spebk0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   84;
-function spebk1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   85;
-function speby0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   86;
-function speby1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index   87;
-function speent(x: ArbFloat): longint; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}                                                                                               external 'TpNumLib'  index   88;
-function speerf(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}                                                                                              external 'TpNumLib'  index   89;
-function speefc(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}                                                                                              external 'TpNumLib'  index   90;
-function spegam(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}                                                                                              external 'TpNumLib'  index   91;
-function spelga(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 20 oktober 1993}                                                                                              external 'TpNumLib'  index   92;
-function spemax(a, b: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}                                                                                           external 'TpNumLib'  index   93;
-function spepol(x: ArbFloat; var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}                                                                  external 'TpNumLib'  index   94;
-function spepow(a, b: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}                                                                                           external 'TpNumLib'  index   95;
-function spesgn(x: ArbFloat): ArbInt; {ok 26 oktober 1993}                                                                                                                                        external 'TpNumLib'  index   96;
-function spears(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 21 oktober 1993}                                                                                              external 'TpNumLib'  index   97;
-function spearc(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 21 oktober 1993}                                                                                              external 'TpNumLib'  index   98;
-function spesih(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index   99;
-function specoh(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  100;
-function spetah(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  101;
-function speash(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  102;
-function speach(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  103;
-function speath(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  104;
-function  spl1bspv(q: ArbInt; var kmin1, c1: ArbFloat; x: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                          external 'TpNumLib'  index  105;
-function  spl2bspv(qx, qy: ArbInt; var kxmin1, kymin1, c11: ArbFloat; x, y: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                        external 'TpNumLib'  index  106;
-procedure spl1bspf(M, Q: ArbInt; var XYW1: ArbFloat;var Kmin1, C1, residu: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                    external 'TpNumLib'  index  107;
-procedure spl2bspf(M, Qx, Qy: ArbInt; var XYZW1: ArbFloat;var Kxmin1, Kymin1, C11, residu: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                    external 'TpNumLib'  index  108;
-procedure spl1nati(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                      external 'TpNumLib'  index  109;
-procedure spl1naki(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                      external 'TpNumLib'  index  110;
-procedure spl1cmpi(n: ArbInt; var xyc1: ArbFloat; dy1, dyn: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                   external 'TpNumLib'  index  111;
-procedure spl1peri(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                      external 'TpNumLib'  index  112;
-function  spl1pprv(n: ArbInt; var xyc1: ArbFloat; t: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                               external 'TpNumLib'  index  113;
-procedure spl1nalf(n: ArbInt; var xyw1: ArbFloat; lambda:ArbFloat;var xac1, residu: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                          external 'TpNumLib'  index  114;
-function spl2natv(n: ArbInt; var xyg0: ArbFloat; u, v: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                               external 'TpNumLib'  index  115;
-procedure spl2nalf(n: ArbInt; var xyzw1: ArbFloat; lambda:ArbFloat;var xyg0, residu: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                         external 'TpNumLib'  index  116;
-{procedure Intsle(l: ArbInt; e: ArbFloat); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                                 external 'TpNumLib'  index  117;}
-function dllversion:LONGINT; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                                              external 'TpNumLib'  index   117;
-function exp(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                                      external 'TpNumLib'  index  118;
-function MachCnst(n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                                   external 'TpNumLib'  index  119;
-procedure ipffsn(n: ArbInt; var x, y, a, d2a: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                 external 'TpNumLib'  index  120;
-procedure ipfisn(n: ArbInt; var x, y, d2s: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                    external 'TpNumLib'  index  121;
-function  ipfspn(n: ArbInt; var x, y, d2s: ArbFloat; t: ArbFloat;var term: ArbInt): ArbFloat;{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                              external 'TpNumLib'  index  122;
-procedure ipfpol(m, n: ArbInt; var x, y, b: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                   external 'TpNumLib'  index  123;
-function spline(n: ArbInt; x: complex; var ac: complex; var gammar: ArbFloat; u1: ArbFloat; pf: complex): ArbFloat;{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                        external 'TpNumLib'  index  124;
-procedure splineparameters (n: ArbInt; var ac, alfadc: complex; var lambda, gammar, u1, kwsom, energie: ArbFloat; var pf: complex);{$IFDEF Needsstdcall} stdcall; {$ENDIF}                        external 'TpNumLib'  index  125;
-
-
-FUNCTION CheckVersion: BOOLEAN;
-
-BEGIN
- CheckVersion:=dllVersion=Numlib_dll_version;
-END;
-
-end.
-
-{
-  $Log$
-  Revision 1.2.2.1  2002-01-16 14:57:45  florian
-  no message
-
-  Revision 1.2  2002/01/16 14:47:16  florian
-    + Makefile.fpc added
-    * several small changes to get things running with FPC 1.0.x
-
-  Revision 1.1  2000/07/13 06:34:15  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-}

packages/numlib/ode.pas

@@ -1,347 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Solve first order starting value differential eqs, and
-    sets of first order starting value differential eqs,
-
-    Both versions are not suited for stiff differential equations
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-Unit ode;
-{$I DIRECT.INC}
-
-
-interface
-
-uses typ;
-
-{Solve first order, starting value, differential eqs,
-Calc y(b) for dy/dx=f(x,y) and y(a)=ae}
-
-Procedure odeiv1(f: rfunc2r; a, ya: ArbFloat; Var b, yb: ArbFloat;
-                 ae: ArbFloat; Var term: ArbInt);
-
-{ The same as above, for a set of equations. ya and yb are vectors}
-Procedure odeiv2(f: oderk1n; a: ArbFloat; Var ya, b, yb: ArbFloat;
-                 n: ArbInt; ae: ArbFloat; Var term: ArbInt);
-
-implementation
-
-Procedure odeiv1(f: rfunc2r; a, ya: ArbFloat; Var b, yb: ArbFloat;
-                 ae: ArbFloat; Var term: ArbInt);
-
-Var last, first, reject, goon         : boolean;
-    x, y, d, h, xl, yl, int, hmin,
-    absh,k0, k1, k2, k3, k4, k5,
-    discr, tol, mu, mu1, fh, hl       : ArbFloat;
-Begin
-    x := a;
- y := ya;
- d := b-a;
- yb := y;
- term := 1;
-    If ae <= 0 Then
-     Begin
-        term := 3;
-      exit
-     End;
-    If d <> 0 Then
-     Begin
-        xl := x;
-      yl := y;
-      h := d/4;
-      absh := abs(h);
-        int := abs(d);
-      hmin := int*1e-6;
-        ae := ae/int;
-      first := true;
-      goon := true;
-        while goon Do
-        Begin
-            absh := abs(h);
-            If absh < hmin Then
-             Begin
-                If h>0 Then h := hmin
-              Else h := -hmin;
-                absh := hmin
-             End;
-            If (h >= b-xl) = (h >= 0) Then
-             Begin
-                last := true;
-              h := b-xl;
-              absh := abs(h)
-             End
-         Else last := false;
-            x := xl;
-         y := yl;
-         k0 := f(x,y)*h;
-            x := xl+h*2/9;
-         y := yl+k0*2/9;
-         k1 := f(x,y)*h;
-            x := xl+h/3;
-         y := yl+(k0+k1*3)/12;
-         k2 := f(x,y)*h;
-            x := xl+h/2;
-         y := yl+(k0+k2*3)/8;
-         k3 := f(x,y)*h;
-            x := xl+h*0.8;
-         y := yl+(k0*53-k1*135+k2*126+k3*56)/125;
-         k4 := f(x,y)*h;
-            If last Then x := b
-         Else x := xl+h;
-            y := yl+(k0*133-k1*378+k2*276+k3*112+k4*25)/168;
-         k5 := f(x,y)*h;
-            discr := abs(21*(k0-k3)-162*(k2-k3)-125*(k4-k3)+42*(k5-k3))/14;
-            tol := absh*ae;
-            mu := 1/(1+discr/tol)+0.45;
-            reject := discr > tol;
-            If reject Then
-             Begin
-                If absh <= hmin Then
-                 Begin
-                    b := xl;
-                  yb := yl;
-                  term := 2;
-                  exit
-                 End;
-                h := mu*h
-             End
-         Else
-            Begin
-                If first Then
-                 Begin
-                    first := false;
-                  hl := h;
-                  h := mu*h
-                 End
-             Else
-                Begin
-                    fh := mu*h/hl+mu-mu1;
-                 hl := h;
-                 h := fh*h
-                End;
-                mu1 := mu;
-                y := yl+(-k0*63+k1*189-k2*36-k3*112+k4*50)/28;
-             k5 := f(x,y)*hl;
-                y := yl+(k0*35+k2*162+k4*125+k5*14)/336;
-                If b <> x Then
-                 Begin
-                    xl := x;
-                  yl := y
-                 End
-             Else
-                Begin
-                    yb := y;
-                 goon := false
-                End
-            End {not reject}
-        End; {while}
-     End {d<>0}
-End; {odeiv1}
-
-Procedure odeiv2(f: oderk1n; a: ArbFloat; Var ya, b, yb: ArbFloat;
-                 n: ArbInt; ae: ArbFloat; Var term: ArbInt);
-
-Var pya, pyb, yl, k0, k1, k2, k3, k4, k5, y : ^arfloat1;
-    i, jj, ns                               : ArbInt;
-    last, first, reject, goon               : boolean;
-    x, xl, hmin, int, hl, absh, fhm,
-    discr, tol, mu, mu1, fh, d, h           : ArbFloat;
-Begin
-    If (ae <= 0) Or (n < 1) Then
-     Begin
-        term := 3;
-      exit
-     End;
-    ns := n*sizeof(ArbFloat);
-    pya := @ya;
- pyb := @yb;
- move(pya^[1], pyb^[1], ns);
- term := 1;
-    getmem(yl, ns);
- getmem(k0, ns);
- getmem(k1, ns);
- getmem(k2, ns);
-    getmem(k3, ns);
- getmem(k4, ns);
- getmem(k5, ns);
- getmem(y, ns);
-    x := a;
- d := b-a;
- move(pya^[1], y^[1], ns);
-    If d <> 0 Then
-     Begin
-        xl := x;
-      move(y^[1], yl^[1], ns);
-      h := d/4;
-      absh := abs(h);
-        int := abs(d);
-      hmin := int*1e-6;
-      hl := ae;
-      ae := ae/int;
-        first := true;
-      goon := true;
-        while goon Do
-        Begin
-            absh := abs(h);
-            If absh < hmin Then
-             Begin
-                If h > 0 Then h := hmin
-              Else h := -hmin;
-                absh := hmin
-             End;
-            If (h >= b-xl) = (h >= 0) Then
-             Begin
-                last := true;
-              h := b-xl;
-              absh := abs(h)
-             End
-         Else last := false;
-            x := xl;
-         move(yl^[1], y^[1], ns);
-            f(x, y^[1], k0^[1]);
-            For i:=1 To n Do
-             k0^[i] := k0^[i]*h;
-            x := xl+h*2/9;
-            For jj:=1 To n Do
-             y^[jj] := yl^[jj]+k0^[jj]*2/9;
-            f(x, y^[1], k1^[1]);
-            For i:=1 To n Do
-             k1^[i] := k1^[i]*h;
-            x := xl+h/3;
-            For jj:=1 To n Do
-             y^[jj] := yl^[jj]+(k0^[jj]+k1^[jj]*3)/12;
-            f(x, y^[1], k2^[1]);
-            For i:=1 To n Do
-             k2^[i] := k2^[i]*h;
-            x := xl+h/2;
-            For jj:=1 To n Do
-             y^[jj] := yl^[jj]+(k0^[jj]+k2^[jj]*3)/8;
-            f(x, y^[1], k3^[1]);
-            For i:=1 To n Do
-             k3^[i] := k3^[i]*h;
-            x := xl+h*0.8;
-            For jj:=1 To n Do
-             y^[jj] := yl^[jj]+
-                       (k0^[jj]*53-k1^[jj]*135+k2^[jj]*126+k3^[jj]*56)/125;
-            f(x, y^[1], k4^[1]);
-            For i:=1 To n Do
-             k4^[i] := k4^[i]*h;
-            If last Then x := b
-         Else x := xl+h;
-            For jj:=1 To n Do
-             y^[jj] := yl^[jj]+(k0^[jj]*133-k1^[jj]*378+k2^[jj]*276+
-                               k3^[jj]*112+k4^[jj]*25)/168;
-            f(x, y^[1], k5^[1]);
-            For i:=1 To n Do
-             k5^[i] := k5^[i]*h;
-            reject := false;
-         fhm := 0;
-         tol := absh*ae;
-            For jj:=1 To n Do
-             Begin
-                discr := abs((k0^[jj]-k3^[jj])*21-(k2^[jj]-k3^[jj])*162-
-                         (k4^[jj]-k3^[jj])*125+(k5^[jj]-k3^[jj])*42)/14;
-                reject := (discr > tol) Or  reject;
-              fh := discr/tol;
-                If fh > fhm Then fhm := fh
-             End; {jj}
-            mu := 1/(1+fhm)+0.45;
-            If reject Then
-             Begin
-                If absh <= hmin Then
-                 Begin
-                    b := xl;
-                  move(yl^[1], pyb^[1], ns);
-                  term := 2;
-                    freemem(yl, ns);
-                  freemem(k0, ns);
-                    freemem(k1, ns);
-                  freemem(k2, ns);
-                    freemem(k3, ns);
-                  freemem(k4, ns);
-                    freemem(k5, ns);
-                  freemem(y, ns);
-                  exit
-                 End;
-                h := mu*h
-             End
-         Else
-            Begin
-                If first Then
-                 Begin
-                    first := false;
-                  hl := h;
-                  h := mu*h
-                 End
-             Else
-                Begin
-                    fh := mu*h/hl+mu-mu1;
-                 hl := h;
-                 h := fh*h
-                End;
-                mu1 := mu;
-                For jj:=1 To n Do
-                 y^[jj] := yl^[jj]+(-k0^[jj]*63+k1^[jj]*189
-                                  -k2^[jj]*36-k3^[jj]*112+k4^[jj]*50)/28;
-                f(x, y^[1], k5^[1]);
-                For i:=1 To n Do
-                 k5^[i] := k5^[i]*hl;
-                For jj:=1 To n Do
-                 y^[jj] := yl^[jj]+(k0^[jj]*35+k2^[jj]*162+k4^[jj]*125
-                           +k5^[jj]*14)/336;
-                If b <> x Then
-                 Begin
-                    xl := x;
-                  move(y^[1], yl^[1], ns)
-                 End
-             Else
-                Begin
-                    move(y^[1], pyb^[1], ns);
-                 goon := false
-                End
-            End {not reject}
-       End {while}
-     End; {d<>0}
-  freemem(yl, ns);
- freemem(k0, ns);
- freemem(k1, ns);
- freemem(k2, ns);
-  freemem(k3, ns);
- freemem(k4, ns);
- freemem(k5, ns);
- freemem(y, ns)
-End; {odeiv2}
-
-End.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:45  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:15  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/omv.pas

@@ -1,282 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    This unit contains some basic matrix operations.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-Unit omv;
-{$I direct.inc}
-
-interface
-
-uses typ;
-
-{Calculates inproduct of vectors a and b which have N elements. The first
-element is passed in a and b}
-Function omvinp(Var a, b: ArbFloat; n: ArbInt): ArbFloat;
-
-{Multiplication of two matrices C=AxB }
-Procedure omvmmm(Var a: ArbFloat; m, n, rwa: ArbInt;
-                 Var b: ArbFloat; k, rwb: ArbInt;
-                 Var c: ArbFloat; rwc: ArbInt);
-
-{Multiplication of a matrix(A) with a vector(B), C=A x B}
-Procedure omvmmv(Var a: ArbFloat; m, n, rwidth: ArbInt; Var b, c: ArbFloat);
-
-{Calculate 1-Norm of matrix A}
-Function omvn1m(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
-
-{Calculate 1-Norm of vector A}
-Function omvn1v(Var a: ArbFloat; n: ArbInt): ArbFloat;
-
-{Calculate 2-Norm of vector A}
-Function omvn2v(Var a: ArbFloat; n: ArbInt): ArbFloat;
-
-{Calculate Frobenius-Norm of mxn matrix A}
-Function omvnfm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
-
-{Calculates maximum (infinite) norm of mxn matrix a}
-Function omvnmm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
-
-{Calculates maximum (infinite) norm of n-Vector }
-Function omvnmv(Var a: ArbFloat; n: ArbInt): ArbFloat;
-
-{Transponate mxn matrix A  (which was declared rwa bytes wide), put
-it to C (rwc was declared elements wide)}
-Procedure omvtrm(Var a: ArbFloat; m, n, rwa: ArbInt; Var c: ArbFloat;
-                        rwc: ArbInt);
-
-IMPLEMENTATION
-
-Function omvinp(Var a, b: ArbFloat; n: ArbInt): ArbFloat;
-
-Var        pa, pb : ^arfloat1;
-                i : ArbInt;
-                s : ArbFloat;
-Begin
-  If n<1 Then
-    exit(0);
-  pa := @a;
- pb := @b;
- s := 0;
-  For i:=1 To n Do
-    Begin
-      s := s+pa^[i]*pb^[i]
-    End; {i}
-  omvinp := s
-End; {omvinp}
-
-Procedure omvmmm(Var a: ArbFloat; m, n, rwa: ArbInt;
-                 Var b: ArbFloat; k, rwb: ArbInt;
-                 Var c: ArbFloat; rwc: ArbInt);
-
-Var           pa, pb, pc : ^arfloat1;
-     i, j, l, inda, indc : ArbInt;
-                       s : ArbFloat;
-Begin
-  If (m<1) Or (n<1) Or (k<1) Then
-   exit;
-  pa := @a;
- pb := @b;
- pc := @c;
-  For i:=1 To m Do
-    Begin
-      inda := (i-1)*rwa;
-      indc := (i-1)*rwc;
-      For j:=1 To k Do
-        Begin
-          s := 0;
-          For l:=1 To n Do
-            s := s+pa^[inda+l]*pb^[(l-1)*rwb+j];
-          pc^[indc+j] := s
-        End {j}
-    End; {i}
-End; {omvmmm}
-
-Procedure omvmmv(Var a: ArbFloat; m, n, rwidth: ArbInt; Var b, c: ArbFloat);
-
-Var     pa, pb, pc : ^arfloat1;
-         i, j, ind : ArbInt;
-Begin
-  If (m<1) Or (n<1) Then
-    exit;
-  pa := @a;
- pb := @b;
- pc := @c;
- ind := 0;
-  For i:=1 To m Do
-    Begin
-      pc^[i] := omvinp(pa^[ind+1], pb^[1], n);
-      ind := ind+rwidth
-    End; {i}
-End; {omvmmv}
-
-Function omvn1m(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
-
-Var           pa : ^arfloat1;
-            i, j : ArbInt;
-     norm, normc : ArbFloat;
-
-Begin
-  If (m<1) Or (n<1) Then
-    exit;
-  pa := @a;
- norm := 0;
-  For j:=1 To n Do
-    Begin
-      normc := 0;
-      For i:=1 To m Do
-        normc := normc+abs(pa^[j+(i-1)*rwidth]);
-      If norm<normc Then
-        norm := normc
-    End;
-  omvn1m := norm
-End {omvn1m};
-
-Function omvn1v(Var a: ArbFloat; n: ArbInt): ArbFloat;
-
-Var   pa : ^arfloat1;
-       i : ArbInt;
-    norm : ArbFloat;
-
-Begin
-  If n<1 Then
-    exit;
-  pa := @a;
-  norm := 0;
-  For i:=1 To n Do
-    norm := norm+abs(pa^[i]);
-  omvn1v := norm
-End {omvn1v};
-
-Function omvn2v(Var a: ArbFloat; n: ArbInt): ArbFloat;
-
-Var   pa : ^arfloat1;
-       i : ArbInt;
-    norm : ArbFloat;
-
-Begin
-  If n<1 Then
-    exit;
-  pa := @a;
-  norm := 0;
-  For i:=1 To n Do
-    norm := norm+sqr(pa^[i]);
-  omvn2v := sqrt(norm)
-End {omvn2v};
-
-Function omvnfm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
-
-Var      pa : ^arfloat1;
-    i, j, k : ArbInt;
-       norm : ArbFloat;
-
-Begin
-  If (m<1) Or (n<1) Then
-    exit;
-  pa := @a;
- norm := 0;
- k := 0;
-  For i:=1 To m Do
-    Begin
-      For j:=1 To n Do
-        norm := norm+sqr(pa^[j+k]);
-      k := k+rwidth
-    End;
-  omvnfm := sqrt(norm)
-End {omvnfm};
-
-Function omvnmm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
-
-Var          pa : ^arfloat1;
-           i, k : ArbInt;
-    normr, norm : ArbFloat;
-
-Begin
-  If (m<1) Or (n<1) Then
-    exit;
-  pa := @a;
- norm := 0;
- k := 0;
-  For i:=1 To m Do
-    Begin
-      normr := omvn1v(pa^[1+k], n);
-      If norm<normr Then
-        norm := normr;
-      k := k+rwidth
-    End;
-  omvnmm := norm
-End {omvnmm};
-
-Function omvnmv(Var a: ArbFloat; n: ArbInt): ArbFloat;
-
-Var       pa : ^arfloat1;
-           i : ArbInt;
-    norm, aa : ArbFloat;
-
-Begin
-  If (n<1) Then
-    exit;
-  pa := @a;
-  norm := 0;
-  For i:=1 To n Do
-    Begin
-      aa := abs(pa^[i]);
-      If aa>norm Then
-        norm := aa
-    End;
-  omvnmv := norm
-End {omvnmv};
-
-Procedure omvtrm(Var a: ArbFloat; m, n, rwa: ArbInt;
-                 Var c: ArbFloat; rwc: ArbInt);
-
-Var        pa, pc : ^arfloat1;
-           ind, i, j : ArbInt;
-
-Begin
-  If (m<1) Or (n<1) Then
-    exit;
-  pa := @a;
- pc := @c;
- ind := 0;
-  For i:=1 To m Do
-    Begin
-      For j:=1 To n Do
-        pc^[(j-1)*rwc+i] := pa^[ind+j];
-      ind := ind+rwa
-    End; {i}
-End; {omvtrm}
-
-End.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:45  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:15  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/roo.pas

@@ -1,1452 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Unit to find roots of (various kinds of) equations
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-Unit roo;
-{$i direct.inc}
-
-interface
-
-uses typ, spe;
-
-{Find the all roots of the binomial eq. x^n=a, with "a" a complex number}
-
-Procedure roobin(n: ArbInt; a: complex; Var z: complex; Var term: ArbInt);
-
-{Find root point of f(x)=0 with f(x) a continuous function on domain [a,b]
- If f(a)*f(b)<=0 then there must be (at least) one rootpoint}
-
-Procedure roof1r(f: rfunc1r; a, b, ae, re: ArbFloat; Var x: ArbFloat;
-                 Var term: ArbInt);
-
-{Determine all zeropoints for a given n'th degree polynomal with real
-coefficients}
-
-Procedure roopol(Var a: ArbFloat; n: ArbInt; Var z: complex;
-                 Var k, term: ArbInt);
-
-{Find roots for a simple 2th degree eq  x^2+px+q=0 with p and q real}
-
-Procedure rooqua(p, q: ArbFloat; Var z1, z2: complex);
-
-{Roofnr is undocumented, but verry big}
-
-Procedure roofnr(f: roofnrfunc; n: ArbInt; Var x, residu: ArbFloat; re: ArbFloat;
-                 Var term: ArbInt);
-
-{ term : 1     succesful termination
-         2     Couldn't reach the specified precision
-               Value X is the best one which could be found.
-         3     Wrong input
-         4     Too many functionvalues calculated, try to recalc with the
-                calculated X
-         5     Not enough progress. Possibly there is no solution, or the
-               solution is too close to 0. Try to choose a different
-               initial startingvalue
-         6     Process wants to calculate a function value outside the by
-               "deff" defined area.
-}
-
-implementation
-
-Procedure roobin(n: ArbInt; a: complex; Var z: complex; Var term: ArbInt);
-{ This procedure solves the binomial equation z**n = a, with a complex}
-
-Var         i, j, k : ArbInt;
-    w, fie, dfie, r : ArbFloat;
-                 pz : ^arcomp1;
-Begin
-  If n<1 Then
-   Begin
-      term := 2;
-    exit
-   End;
-  term := 1;
- pz := @z;
- dfie := 2*pi/n;
- k := 1;
-  If a.im=0 Then
-   Begin
-      If a.re>0 Then
-       Begin
-          r := spepow(a.re, 1/n);
-        pz^[1].Init(r, 0);
-          k := k+1;
-        i := (n-1) Div 2;
-          If Not odd(n) Then
-           Begin
-              pz^[k].Init(-r, 0);
-            k := k+1
-           End;
-          For j:=1 To i Do
-           Begin
-              w := j*dfie;
-              pz^[k].Init(r*cos(w), r*sin(w));
-              pz^[k+1] := pz^[k];
-            pz^[k+1].Conjugate;
-              k := k+2
-           End
-       End
-    Else
-      Begin
-          fie := pi/n;
-       r := spepow(-a.re, 1/n);
-       i := n Div 2-1;
-          If odd(n) Then
-           Begin
-              pz^[k].Init(-r, 0);
-            k := k+1
-           End;
-          For j:=0 To i Do
-           Begin
-              w := fie+j*dfie;
-              pz^[k].Init(r*cos(w), r*sin(w));
-              pz^[k+1] := pz^[k];
-            pz^[k+1].Conjugate;
-              k := k+2
-           End
-      End
-   End
- Else
-  Begin
-      If abs(a.re)>=abs(a.im) Then
-       r := spepow(abs(a.re)*sqrt(1+sqr(a.im/a.re)), 1/n)
-      Else r := spepow(abs(a.im)*sqrt(1+sqr(a.re/a.im)), 1/n);
-      fie := a.arg/n;
-   i := n Div 2;
-      For j:=0 To n-1 Do
-       Begin
-          w := fie+(j-i)*dfie;
-          pz^[j+1].Init(r*cos(w), r*sin(w))
-       End
-   End
-End {roobin};
-
-Procedure roof1r(f: rfunc1r; a, b, ae, re: ArbFloat; Var x: ArbFloat;
-                 Var term: ArbInt);
-
-Var fa, fb, c, fc, m, tol, w1, w2 : ArbFloat;
-                                k : ArbInt;
-                             stop : boolean;
-
-Begin
-  fa := f(a);
- fb := f(b);
-  If (spesgn(fa)*spesgn(fb)=1) Or (ae<0) Or (re<0)
-   Then  {wrong input}
-    Begin
-      term := 3;
-     exit
-    End;
-  If abs(fb)>abs(fa) Then
-    Begin
-      c := b;
-     fc := fb;
-     x := a;
-     b := a;
-     fb := fa;
-     a := c;
-     fa := fc
-    End
- Else
-    Begin
-      c := a;
-     fc := fa;
-     x := b
-    End;
-  k := 0;
-  tol := ae+re*spemax(abs(a), abs(b));
-  w1 := abs(b-a);
- stop := false;
-  while (abs(b-a)>tol) and (fb<>0) and (Not stop) Do
-    Begin
-      m := (a+b)/2;
-      If (k>=2) Or (fb=fc) Then x := m
-     Else
-        Begin
-          x := (b*fc-c*fb)/(fc-fb);
-          If abs(b-x)<tol Then x := b-tol*spesgn(b-a);
-          If spesgn(x-m)=spesgn(x-b) Then x := m
-        End;
-      c := b;
-     fc := fb;
-     b := x;
-     fb := f(x);
-      If spesgn(fa)*spesgn(fb)>0 Then
-        Begin
-          a := c;
-         fa := fc;
-         k := 0
-        End
-     Else k := k+1;
-      If abs(fb)>=abs(fa) Then
-        Begin
-          c := b;
-         fc := fb;
-         x := a;
-         b := a;
-         fb := fa;
-         a := c;
-         fa := fc;
-         k := 0
-        End;
-      tol := ae+re*spemax(abs(a), abs(b));
-      w2 := abs(b-a);
-      If w2>=w1 Then
-        Begin
-          stop := true;
-         term := 2
-        End;
-      w1 := w2
-    End;
-  If Not stop Then term := 1
-End {roof1r};
-
-Procedure roopol(Var a: ArbFloat; n: ArbInt; Var z: complex;
-                 Var k, term: ArbInt);
-
-Const max = 50;
-
-Type  rnep2 = array[-2..$ffe0 div SizeOf(ArbFloat)] Of ArbFloat;
-
-Var rk, i, j, l, m, length, term1                             : ArbInt;
-    p, q, r, s, f, df, delp, delq, delr, telp, telq, sn, sn1,
-    sn2, noise, noise1, noise2, g, absr, maxcoef, coef, d, t,
-    maxx, fac, meps                                           : ArbFloat;
-    convergent, linear, quadratic                             : boolean;
-    u, v                                                      : complex;
-    pa                                                        : ^arfloat1;
-    pb, pc, ph                                                : ^rnep2;
-    pz                                                        : ^arcomp1;
-
-Function gcd(n, m: ArbInt): ArbInt;
-{ This function computes the greatest common divisor of m and n}
-
-Var r : ArbInt;
-Begin
-    r := n Mod m;
-    while r>0 Do
-    Begin
-        n := m;
-     m := r;
-     r := n Mod m
-    End;
-    gcd := m
-End {gcd};
-Begin
-    If n<1 Then
-     Begin
-        term := 3;
-      exit
-     End;
-    length := (n+3)*sizeof(ArbFloat);
-    getmem(pb, length);
- getmem(pc, length);
- getmem(ph, length);
-    meps := macheps;
-    pa := @a;
- pz := @z;
-    pb^[-2] := 0;
- pb^[-1] := 0;
- pc^[-2] := 0;
- pc^[-1] := 0;
- ph^[-1] := 0;
- ph^[0] := 1;
-    For i:=1 To n Do
-     ph^[i] := pa^[i];
-    k := 0;
-    while (n>0) and (ph^[n]=0) Do
-    Begin
-        k := k+1;
-     pz^[k].Init(0, 0);
-     n := n-1
-    End;
-    If n>0 Then
-     Begin
-        l := n;
-      i := 1;
-        while (l>1) and (i<n) Do
-        Begin
-            If ph^[i] <> 0 Then l := gcd(l, n-i);
-         i := i+1
-        End;
-        If l>1 Then
-         Begin
-            n := n Div l;
-            For i:=1 To n Do
-             ph^[i] := ph^[l*i]
-         End
-     End;
-    convergent := true ;
-    while (n>0) and convergent Do
-    Begin
-        linear := false;
-     quadratic := false ;
-        If n=1 Then
-         Begin
-            r := -ph^[1]/ph^[0];
-          linear := true
-         End;
-        If n=2 Then
-         Begin
-            p := ph^[1]/ph^[0];
-          q := ph^[2]/ph^[0];
-          quadratic := true
-         End;
-        If n>2 Then
-         Begin
-            If (ph^[n-1]=0) Or (ph^[n-2]=0) Then
-             Begin
-                maxcoef := abs(ph^[n-1]/ph^[n]);
-                For i:=2 To n Do
-                 Begin
-                    coef := spepow(abs(ph^[n-i]/ph^[n]),1/i);
-                    If maxcoef<coef Then maxcoef := coef
-                 End;
-                maxcoef := 2*maxcoef
-             End;
-            If ph^[n-1]=0 Then r := -spesgn(ph^[0])*spesgn(ph^[n])/maxcoef
-            Else r := -ph^[n]/ph^[n-1];
-            If ph^[n-2]=0 Then
-             Begin
-                p := 0;
-              q := -1/sqr(maxcoef)
-             End
-          Else
-            Begin
-                q := ph^[n]/ph^[n-2];
-             p := (ph^[n-1]-q*ph^[n-3])/ph^[n-2]
-            End;
-            m := 0;
-            while (m<max) and (Not linear) and (Not quadratic) Do
-            Begin
-                m := m+1;
-                For j:=0 To n Do
-                 pb^[j] := ph^[j]-p*pb^[j-1]-q*pb^[j-2];
-                For j:=0 To n-2 Do
-                 pc^[j] := pb^[j]-p*pc^[j-1]-q*pc^[j-2];
-                pc^[n-1] := -p*pc^[n-2]-q*pc^[n-3];
-                s := sqr(pc^[n-2])-pc^[n-1]*pc^[n-3];
-                telp := pb^[n-1]*pc^[n-2]-pb^[n]*pc^[n-3];
-                telq := pb^[n]*pc^[n-2]-pb^[n-1]*pc^[n-1];
-                If s=0 Then
-                 Begin
-                    delp := telp;
-                  delq := telq
-                 End
-             Else
-                Begin
-                    delp := telp/s;
-                 delq := telq/s
-                End;
-                noise1 := 0;
-             sn1 := 0;
-             sn := 1;
-                noise2 := 4*abs(pb^[n])+3*abs(p*pb^[n-1]);
-                For j:=n-1 Downto 0 Do
-                 Begin
-                    g := 4*abs(pb^[j])+3*abs(p*pb^[j-1]);
-                    noise1 := noise1+g*abs(sn);
-                    sn2 := sn1;
-                  sn1 := sn;
-                  sn := -p*sn1-q*sn2;
-                    noise2 := noise2+g*abs(sn)
-                 End;
-                d := p*p-4*q;
-                absr := abs(r);
-             f := ph^[0];
-             df := 0;
-             noise := abs(f)/2;
-                For j:=1 To n Do
-                 Begin
-                    df := f+r*df;
-                  f := ph^[j]+r*f;
-                  noise := abs(f)+absr*noise
-                 End;
-                If df=0 Then delr := f
-             Else delr := f/df;
-                If (abs(telp)<=meps*(noise1*abs(pc^[n-2])+
-                               noise2*abs(pc^[n-3])))
-                   And
-                   (abs(telq)<=meps*(noise1* abs(pc^[n-1])+
-                             noise2*abs(pc^[n-2])))
-                 Then quadratic := true
-                Else
-                 Begin
-                    p := p+delp;
-                  q := q+delq
-                 End;
-                If abs(f)<=2*meps*noise Then linear := true
-             Else r := r-delr
-            End
-         End;
-        convergent := linear Or quadratic;
-        If linear Then
-         Begin
-            If l=1 Then
-             Begin
-                k := k+1;
-              pz^[k].xreal := r;
-              pz^[k].imag := 0
-             End
-          Else
-            Begin
-                u.init(r, 0);
-             roobin(l, u, pz^[k+1], term1);
-             k := k+l
-            End;
-            maxx := 0;
-          rk := 0;
-          fac := 1;
-            For j:=n Downto 0 Do
-             Begin
-                s := abs(ph^[j]*fac);
-              fac := fac*r;
-                If s>maxx Then
-                 Begin
-                    maxx := s;
-                  rk := j-1
-                 End
-             End;
-            For j:=1 To rk Do
-             ph^[j] := ph^[j]+r*ph^[j-1];
-            If rk<n-1 Then
-             Begin
-                s := ph^[n-1];
-              ph^[n-1] := -ph^[n]/r;
-                For j:=n-2 Downto rk+1 Do
-                 Begin
-                    t := ph^[j];
-                  ph^[j] := (ph^[j+1]-s)/r;
-                  s := t
-                 End
-             End;
-            n := n-1;
-         End
-     Else
-        If quadratic Then
-         Begin
-            If l=1 Then
-             Begin
-                rooqua(p,q,pz^[k+1],pz^[k+2]);
-              k := k+2
-             End
-          Else
-            Begin
-                rooqua(p,q,u,v);
-             roobin(l,u,pz^[k+1],term1);
-                roobin(l,v,pz^[k+l+1],term1);
-             k := k+2*l
-            End;
-            n := n-2;
-            For j:=1 To n Do
-             ph^[j] := ph^[j]-p*ph^[j-1]-q*ph^[j-2]
-         End
-  End;
-  If k<n Then term := 2
- Else term := 1;
-  freemem(pb, length);
- freemem(pc, length);
- freemem(ph, length);
-End {roopol};
-
-Procedure rooqua(p, q: ArbFloat; Var z1, z2: complex);
-
-Var s, d : ArbFloat;
-Begin
-    p := -p/2;
- d := sqr(p)-q;
-    If d<0 Then
-     Begin
-        z1.Init(p, sqrt(-d));
-      z2 := z1;
-      z2.conjugate
-     End
- Else
-    Begin
-        If p>0 Then s := p+sqrt(d)
-     Else s := p-sqrt(d);
-        If s=0 Then
-         Begin
-            z1.Init(0, 0);
-          z2 := z1
-         End
-     Else
-        Begin
-            z1.Init(s, 0);
-         z2.Init(q/s, 0)
-        End
-    End
-End {rooqua};
-
-Procedure roo001(uplo, trans, diag: char; n: ArbInt; Var ap1, x1: ArbFloat;
-                 incx: ArbInt);
-
-Var 
-    ap   : arfloat1 absolute ap1;
-    x    : arfloat1 absolute x1;
-    temp : ArbFloat;
-    i, info, ix, j, jx, k, kk, kx: ArbInt;
-    nounit: boolean;
-Begin
-    info := 0;
- uplo := upcase(uplo);
- trans := upcase(trans);
- diag := upcase(diag);
-    If n=0 Then exit;
-    nounit := diag='N';
-    If incx<=0 Then kx := 1-(n-1)*incx
- Else kx := 1;
-    If trans='N' Then
-     Begin
-        If uplo='U' Then
-         Begin
-            kk := 1;
-          jx := kx;
-            For j:=1 To n Do
-             Begin
-                If x[jx]<>0 Then
-                 Begin
-                    temp := x[jx];
-                  ix := kx;
-                    For k:=kk To kk+j-2 Do
-                     Begin
-                        x[ix] := x[ix]+temp*ap[k];
-                        inc(ix, incx)
-                     End;
-                    If nounit Then x[jx] := x[jx]*ap[kk+j-1]
-                 End;
-                inc(jx, incx);
-              inc(kk, j)
-             End
-         End
-      Else
-        Begin
-            kk := n*(n+1) Div 2;
-         inc(kx, (n-1)*incx);
-         jx := kx;
-            For j:=n Downto 1 Do
-             Begin
-               If x[jx]<>0 Then
-                Begin
-                   temp := x[jx];
-                 ix := kx;
-                   For k:=kk Downto kk-(n-(j+1)) Do
-                    Begin
-                       x[ix] := x[ix]+temp*ap[k];
-                     dec(ix, incx)
-                    End;
-                   If nounit Then x[jx] := x[jx]*ap[kk-n+j]
-                End;
-               dec(jx, incx);
-              dec(kk, n-j+1)
-             End
-        End
-     End
- Else
-    Begin
-        If uplo='U' Then
-         Begin
-            kk := n*(n+1) Div 2;
-          jx := kx+(n-1)*incx;
-            For j:= n Downto 1 Do
-             Begin
-               temp := x[jx];
-              ix := jx;
-               If nounit Then temp := temp*ap[kk];
-               For k:= kk-1 Downto kk-j+1 Do
-                Begin
-                   dec(ix, incx);
-                 temp := temp+ap[k]*x[ix]
-                End;
-               x[jx] := temp;
-              dec(jx, incx);
-              dec(kk, j)
-             End
-         End
-     Else
-        Begin
-            kk := 1;
-         jx := kx;
-            For j:=1 To n Do
-             Begin
-                temp := x[jx];
-              ix := jx;
-                If nounit Then temp := temp*ap[kk];
-                For k:=kk+1 To kk+n-j Do
-                 Begin
-                    inc(ix, incx);
-                  temp := temp+ap[k]*x[ix]
-                 End;
-                x[jx] := temp;
-              inc(jx, incx);
-              inc(kk, n-j+1)
-             End
-        End
-    End
-End;
-
-Procedure roo002(uplo, trans, diag: char; n: ArbInt;
-                  Var ap1, x1: ArbFloat; incx: ArbInt );
-
-Var ap : arfloat1 absolute ap1;
-    x  : arfloat1 absolute x1;
-    temp : ArbFloat;
-    i, info, ix, j, jx, k, kk, kx: ArbInt;
-    nounit: boolean;
-Begin
-    info := 0;
- uplo := upcase(uplo);
- trans := upcase(trans);
- diag := upcase(diag);
-    If n=0 Then exit;
-    nounit := diag='N';
-    If incx<=0 Then kx := 1-(n-1)*incx
- Else kx := 1;
-    If trans='N' Then
-     Begin
-        If uplo='U' Then
-         Begin
-            kk := n*(n+1) Div 2;
-          jx := kx+(n-1)*incx;
-            For j:=n Downto 1 Do
-             Begin
-                If x[jx]<>0 Then
-                 Begin
-                    If nounit Then x[jx] := x[jx]/ap[kk];
-                    temp := x[jx];
-                  ix := jx;
-                    For k:=kk-1 Downto kk-j+1 Do
-                     Begin
-                        dec(ix, incx);
-                      x[ix] := x[ix]-temp*ap[k];
-                     End
-                 End;
-                dec(jx, incx);
-              dec(kk, j)
-             End
-         End
-      Else
-        Begin
-            kk := 1;
-         jx := kx;
-            For j:=1 To n Do
-             Begin
-                If x[jx]<>0 Then
-                 Begin
-                    If nounit Then x[jx] := x[jx]/ap[kk];
-                    temp := x[jx];
-                  ix := jx;
-                    For k:= kk+1 To kk+n-j Do
-                     Begin
-                        inc(ix, incx);
-                      x[ix] := x[ix]-temp*ap[k]
-                     End;
-                 End;
-                inc(jx, incx);
-              inc(kk, n-j+1)
-             End
-         End
-     End
- Else
-     Begin
-         If uplo='U' Then
-          Begin
-             kk := 1;
-           jx := kx;
-             For j:= 1 To n Do
-              Begin
-                 temp := x[jx];
-               ix := kx;
-                 For k:= kk To kk+j-2 Do
-                  Begin
-                     temp := temp-ap[k]*x[ix];
-                     inc(ix, incx);
-                  End;
-                 If nounit Then temp := temp/ap[kk+j-1];
-                 x[jx] := temp;
-               inc(jx, incx);
-               inc(kk, j)
-              End
-          End
-      Else
-          Begin
-              kk := n*(n+1) Div 2;
-           kx := kx+(n-1)*incx;
-           jx := kx;
-              For j:=n Downto 1 Do
-               Begin
-                  temp := x[jx];
-                ix := kx;
-                  For k:= kk Downto kk-(n-(j+1)) Do
-                   Begin
-                      temp := temp-ap[k]*x[ix];
-                    dec(ix, incx)
-                   End;
-                  If nounit Then temp := temp/ap[kk-n+j];
-                  x[jx] := temp;
-                dec(jx, incx);
-                dec(kk, n-j+1)
-               End
-          End
-     End
-End;
-
-Procedure roo003( n: ArbInt; Var x1: ArbFloat; incx: ArbInt;
-                  Var scale, sumsq: ArbFloat );
-
-Var absxi : ArbFloat;
-    i, ix : ArbInt;
-    x     : arfloat1 absolute x1;
-Begin
-    ix := 1;
-    If n>0 Then
-     For i:=1 To n Do
-      Begin
-        If x[ix]<>0 Then
-         Begin
-            absxi := abs(x[ix]);
-            If (scale<absxi) Then
-             Begin
-                sumsq := 1+sumsq*sqr(scale/absxi);
-              scale := absxi
-             End
-          Else sumsq := sumsq + sqr(absxi/scale)
-         End;
-        inc(ix, incx)
-      End
-End;
-
-Function norm2( n: ArbInt; Var x1: ArbFloat; incx: ArbInt): ArbFloat;
-
-Var  scale, ssq : ArbFloat;
-     sqt: ArbFloat;
-Begin
-    If n<1 Then norm2 := 0
- Else
-    If n=1 Then norm2 := abs(x1)
- Else
-    Begin
-        scale := 0;
-     ssq := 1;
-        roo003(n, x1, incx, scale, ssq );
-        sqt := sqrt( ssq );
-        If scale<(giant/sqt) Then norm2 := scale*sqt
-     Else norm2 := giant
-    End
-End;
-
-Procedure roo004(n: ArbInt; Var r1, diag1, qtb1: ArbFloat;
-                 delta: ArbFloat; Var x1: ArbFloat);
-
-Var 
-   r     : arfloat1 absolute r1;
-   diag  : arfloat1 absolute diag1;
-   qtb   : arfloat1 absolute qtb1;
-   x     : arfloat1 absolute x1;
-   wa1, wa2     : ^arfloat1;
-   alpha, bnorm, gnorm, qnorm, sgnorm, temp: ArbFloat;
-   i, j, jj, l  : ArbInt;
-Begin
-    getmem(wa1, n*sizeof(ArbFloat));
- getmem(wa2, n*sizeof(ArbFloat));
-    jj := 1;
-    For j:=1 To n Do
-     Begin
-        wa1^[j] := r[jj];
-        If r[jj]=0 Then
-         Begin
-            temp := 0;
-          l := j;
-            For i:=1 To j-1 Do
-             Begin
-               If abs(r[l])>temp Then temp := abs(r[l]);
-               inc(l, n-i)
-             End;
-            If temp=0 Then r[jj] := macheps
-          Else r[jj] := macheps*temp
-         End;
-        inc(jj, n-j+1)
-     End;
-    move(qtb, x, n*sizeof(ArbFloat));
-    roo002('l','t','n', n, r1, x1, 1);
-    jj := 1;
-    For j:=1 To n Do
-     Begin
-        r[jj] := wa1^[j];
-        inc(jj, n - j + 1)
-     End;
-    For j:=1 To n Do
-     wa2^[j] := diag[j]*x[j];
-    qnorm := norm2(n, wa2^[1], 1);
-    If qnorm>delta Then
-     Begin
-        move(qtb, wa1^, n*sizeof(ArbFloat));
-        roo001('l','n','n', n, r1, wa1^[1], 1);
-        For i:=1 To n Do
-         wa1^[i] := wa1^[i]/diag[i];
-        gnorm := norm2(n, wa1^[1], 1);
-        sgnorm := 0;
-      alpha := delta/qnorm;
-        If gnorm<>0 Then
-         Begin
-            For j:=1 To n Do
-             wa1^[j] := (wa1^[j]/gnorm)/diag[j];
-            move(wa1^, wa2^, n*sizeof(ArbFloat));
-            roo001('l','t','n',n,r1,wa2^[1],1);
-            temp := norm2(n, wa2^[1],1);
-            sgnorm := (gnorm/temp)/temp;
-            alpha := 0;
-            If sgnorm<delta Then
-             Begin
-                bnorm := norm2(n, qtb1, 1);
-                temp := (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta);
-                temp := temp-(delta/qnorm)*sqr(sgnorm/delta) +
-                        sqrt(sqr(temp-delta/qnorm) +
-                         (1-sqr(delta/qnorm))*(1-sqr(sgnorm/delta)));
-                alpha := ((delta/qnorm)*(1-sqr(sgnorm/delta)))/temp
-             End
-         End;
-        If sgnorm<delta Then temp := (1-alpha)*sgnorm
-                        Else temp := (1-alpha)*delta;
-        For j:=1 To n Do
-         x[j] := temp*wa1^[j] + alpha*x[j]
-     End;
-    freemem(wa2, n*sizeof(ArbFloat));
- freemem(wa1, n*sizeof(ArbFloat));
-End;
-
-Procedure roo005(fcn: roofnrfunc; n: ArbInt; Var x1, fvec1, fjac1: ArbFloat;
-                 ldfjac: ArbInt; Var iflag: ArbInt; ml, mu: ArbInt;
-                 epsfcn: ArbFloat; Var wa1, wa2: arfloat1);
-
-Var   eps, h, temp: ArbFloat;
-     i, j, k, msum: ArbInt;
-     x     : arfloat1 absolute x1;
-     fvec  : arfloat1 absolute fvec1;
-     fjac  : arfloat1 absolute fjac1;
-     deff  : boolean;
-Begin
-    If epsfcn>macheps Then eps := sqrt(epsfcn)
- Else eps := sqrt(macheps);
-    msum := ml+mu+1;
-    If msum>=n Then
-     Begin
-        For j:=1 To n Do
-         Begin
-           temp := x[j];
-          h := eps*abs(temp);
-          If h=0 Then h := eps;
-          x[j] := temp+h;
-           deff := true;
-          fcn(x1, wa1[1], deff);
-          If Not deff Then iflag := -1;
-           If iflag<0 Then exit;
-           x[j] := temp;
-           For i:= 1 To n Do
-            fjac[j+(i-1)*ldfjac] := (wa1[i]-fvec[i])/h
-         End
-     End
- Else
-    Begin
-        For k:=1  To msum Do
-         Begin
-            j := k;
-            while j <= n Do
-                      Begin
-                       wa2[j] := x[j];
-                       h := eps*abs(wa2[j]);
-                       If h=0 Then h := eps;
-                       x[j] := wa2[j]+h;
-                       inc(j, msum)
-                      End;
-            deff := true;
-          fcn(x1, wa1[1], deff);
-          If Not deff Then iflag := -1;
-            If iflag<0 Then exit;
-            j := k;
-            while j<= n Do
-                      Begin
-                       x[j] := wa2[j];
-                       h := eps*abs(wa2[j]);
-                       If h=0 Then h := eps;
-                       For i:=1 To n Do
-                        Begin
-                         fjac[j+(i-1)*ldfjac] := 0;
-                         If (i>=(j-mu)) And (i<=(j+ml))
-                          Then fjac[j+(i-1)*ldfjac] := (wa1[i]-fvec[i])/h
-                        End;
-                       inc(j, msum)
-                      End
-         End
-    End
-End;
-
-Procedure roo006(trans: char; m, n: ArbInt; alpha: ArbFloat; Var a1: ArbFloat;
-                 lda: ArbInt; Var x1: ArbFloat; incx : ArbInt; beta: ArbFloat;
-                 Var y1: ArbFloat; incy : ArbInt);
-
-Var  temp : ArbFloat;
-     i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny: ArbInt;
-     x     : arfloat1 absolute x1;
-     y     : arfloat1 absolute y1;
-     a     : arfloat1 absolute a1;
-Begin
-    info := 0;
- trans := upcase(trans);
-    If (m=0) Or (n=0) Or ((alpha=0) And (beta=1)) Then exit;
-    If trans='N' Then
-     Begin
-        lenx := n;
-      leny := m
-     End
- Else
-    Begin
-        lenx := m;
-     leny := n
-    End;
-    If incx>0 Then kx := 1
- Else kx := 1-(lenx-1)*incx;
-    If incy>0 Then ky := 1
- Else ky := 1-(leny-1)*incy;
-    If (beta<>1) Then
-     Begin
-        iy := ky;
-        If beta=0 Then
-         For i:=1 To leny Do
-          Begin
-            y[iy] := 0;
-           inc(iy, incy)
-          End
-          Else
-           For i:=1 To leny Do
-            Begin
-             y[iy] := beta*y[iy];
-             inc(iy, incy)
-            End;
-     End;
-   If alpha=0 Then exit;
-   If trans='N' Then
-    Begin
-       jx := kx;
-       For j:=1 To n Do
-        Begin
-           If x[jx]<>0 Then
-            Begin
-               temp := alpha*x[jx];
-             iy := ky;
-               For i:=1 To m Do
-                Begin
-                  y[iy] := y[iy]+temp*a[j+(i-1)*lda];
-                 inc(iy, incy)
-                End
-            End;
-           inc(jx, incx)
-        End
-    End
- Else
-   Begin
-       jy := ky;
-       For j:=1 To n Do
-        Begin
-           temp := 0;
-         ix := kx;
-           For i:=1 To m Do
-            Begin
-               temp := temp+a[j+(i-1)*lda]*x[ix];
-               inc(ix, incx)
-            End;
-           y[jy] := y[jy]+alpha*temp;
-           inc(jy, incy)
-        End
-   End
-End;
-
-Procedure roo007(m, n: ArbInt; alpha: ArbFloat; Var x1: ArbFloat; incx: ArbInt;
-                  Var y1: ArbFloat; incy: ArbInt; Var a1: ArbFloat; lda: ArbInt);
-
-Var                    temp: ArbFloat;
-     i, info, ix, j, jy, kx: ArbInt;
-     x     : arfloat1 absolute x1;
-     y     : arfloat1 absolute y1;
-     a     : arfloat1 absolute a1;
-Begin
-    info := 0;
-    If (m=0) Or (n=0) Or (alpha=0) Then exit;
-    If incy>0 Then jy := 1
- Else jy := 1-(n-1)*incy;
-    If incx>0 Then kx := 1
- Else kx := 1-(m-1)*incx;
-    For j:=1 To n Do
-     Begin
-        If y[jy]<>0 Then
-         Begin
-            temp := alpha*y[jy];
-            ix  := kx;
-            For i:=1 To m Do
-             Begin
-               a[j +(i-1)*lda] := a[j + (i-1)*lda] + x[ix]*temp;
-               inc(ix, incx)
-             End
-         End;
-        inc(jy, incy)
-     End
-End;
-
-Procedure roo008(n: ArbInt; Var q1: ArbFloat; ldq: ArbInt; Var wa: arfloat1);
-
-Var       q: arfloat1 absolute q1;
-    i, j, k: ArbInt;
-Begin
-     For j:=2 To n Do
-      For i:=1 To j-1 Do
-       q[j+(i-1)*ldq] := 0;
-     For k:=n Downto 1 Do
-      Begin
-         If (q[k+(k-1)*ldq]<>0) And (k<>n) Then
-          Begin
-            roo006('t', n-k+1, n-k, 1, q[k+1+(k-1)*ldq], ldq,
-                   q[k +(k-1)*ldq], ldq, 0, wa[k+1], 1);
-            roo007(n-k+1, n-k, -1/q[k+(k-1)*ldq], q[k+(k-1)*ldq], ldq,
-                   wa[k+1], 1, q[k+1+(k-1)*ldq], ldq)
-          End;
-         For i:=k + 1 To n Do
-          q[k+(i-1)*ldq] := -q[k+(i-1)*ldq];
-         q[k+(k-1)*ldq] := 1-q[k+(k-1)*ldq]
-      End;
-End;
-
-Procedure roo009(n: ArbInt; Var a1: ArbFloat; lda: ArbInt;
-                 Var rdiag1, acnorm1: ArbFloat);
-
-Var  a       : arfloat1 absolute a1;
-     rdiag   : arfloat1 absolute rdiag1;
-     acnorm  : arfloat1 absolute acnorm1;
-     ajnorm  : ArbFloat;
-     i, j    : ArbInt;
-Begin
-    For j:=1 To n Do
-     acnorm[j] := norm2(n, a[j], lda);
-    For j:=1 To n Do
-     Begin
-        ajnorm := norm2(n-j+1, a[j+(j-1)*lda], lda);
-        If ajnorm<>0 Then
-         Begin
-            If a[j+(j-1)*lda]<0 Then ajnorm := -ajnorm;
-            For i:=j To n Do
-             a[j+(i-1)*lda] := a[j+(i-1)*lda]/ajnorm;
-            a[j+(j-1)*lda] := a[j+(j-1)*lda]+1;
-            If j<>n Then
-             Begin
-               roo006('t', n-j+1, n-j, 1, a[j+1+(j-1)*lda], lda,
-                      a[j+(j-1)*lda], lda, 0, rdiag[j+1], 1);
-               roo007(n-j+1, n-j, -1/a[j+(j-1)*lda], a[j+(j-1)*lda], lda,
-                      rdiag[j+1], 1, a[j+1+(j-1)*lda], lda)
-             End
-         End;
-         rdiag[j] := -ajnorm
-     End
-End;
-
-Procedure roo010(n: ArbInt; Var x1: ArbFloat; incx: ArbInt;
-                  Var y1: ArbFloat; incy: ArbInt; c, s:ArbFloat );
-
-Var temp1: ArbFloat;
-    x : arfloat1 absolute x1;
-    y : arfloat1 absolute y1;
-    i, ix, iy: ArbInt;
-Begin
-   If incy>=0 Then iy := 1
- Else iy := 1-(n-1)*incy;
-   If incx>=0 Then ix := 1
- Else ix := 1-(n-1)*incx;
-   For i:=1 To n Do
-    Begin
-      temp1 := x[ix];
-     x[ix] := s*y[iy]+c*temp1;
-     y[iy] := c*y[iy]-s*temp1;
-      inc(ix, incx);
-     inc(iy, incy)
-    End
-End;
-
-Procedure roo011(m, n: ArbInt; Var a1: ArbFloat; lda: ArbInt; Var v1, w1: ArbFloat);
-
-Var a: arfloat1 absolute a1;
-    v: arfloat1 absolute v1;
-    w: arfloat1 absolute w1;
-    sine, cosine: ArbFloat;
-    j, nm1, nmj: ArbInt;
-Begin
-    nm1 := n-1;
-    For nmj:=1 To nm1 Do
-     Begin
-        j := n-nmj;
-        If (abs(v[j])>1) Then
-         Begin
-            cosine := 1/v[j];
-          sine := sqrt(1-sqr(cosine))
-         End
-      Else
-        Begin
-            sine := v[j];
-         cosine := sqrt(1-sqr(sine))
-        End;
-        roo010(m, a[n], lda, a[j], lda, cosine, sine)
-     End;
-   For j:=1 To nm1 Do
-    Begin
-       If (abs(w[j])>1) Then
-        Begin
-           cosine := 1/w[j];
-         sine := sqrt(1-sqr(cosine))
-        End
-     Else
-       Begin
-           sine := w[j];
-        cosine := sqrt(1-sqr(sine))
-       End;
-       roo010(m, a[j], lda, a[n], lda, cosine, sine)
-    End
-End;
-
-Procedure roo012(m, n: ArbInt; Var s1: ArbFloat; ls: ArbInt;
-                 Var u1, v1, w1: ArbFloat; Var sing: boolean);
-
-Const   one = 1.0;
- p5 = 0.5;
- p25 = 0.25;
- zero = 0.0;
-
-Var    cosine, cotan, sine, tangnt, tau: ArbFloat;
-                  i, j, jj, l, nm1, nmj: ArbInt;
-    s : arfloat1 absolute s1;
-    u : arfloat1 absolute u1;
-    v : arfloat1 absolute v1;
-    w : arfloat1 absolute w1;
-Begin
-    jj := (n*(2*m-n+1)) Div 2 - (m-n);
-    If m>=n Then move(s[jj], w[n], (m-n+1)*sizeof(ArbFloat));
-    nm1 := n-1;
-    For nmj:=1 To nm1 Do
-     Begin
-       j := n-nmj;
-      jj := jj-(m-j+1);
-      w[j] := zero;
-       If (v[j]<>zero) Then
-        Begin
-           If (abs(v[n])<abs(v[j])) Then
-            Begin
-               cotan := v[n]/v[j];
-                sine := p5/sqrt(p25+p25*sqr(cotan));
-               cosine := sine*cotan;
-               If (abs(cosine)*giant)>one
-                Then tau := one/cosine
-             Else tau := one
-            End
-         Else
-           Begin
-               tangnt := v[j]/v[n];
-               cosine := p5/sqrt(p25+p25*sqr(tangnt));
-               sine := cosine*tangnt;
-               tau := sine;
-           End;
-           v[n] := sine*v[j]+cosine*v[n];
-           v[j] := tau;
-           roo010(m-j+1, w[j], 1, s[jj], 1, cosine, sine)
-        End
-     End;
-   For i:=1 To m Do
-    w[i] := w[i]+v[n]*u[i];
-   sing := false;
-   For j:=1 To nm1 Do
-    Begin
-       If w[j]<>zero Then
-        Begin
-           If abs(s[jj])<abs(w[j]) Then
-            Begin
-               cotan := s[jj]/w[j];
-             sine := p5/sqrt(p25+p25*sqr(cotan));
-               cosine := sine*cotan;
-               If (abs(cosine)*giant)>one Then tau := one/cosine
-             Else tau := one
-            End
-         Else
-            Begin
-                tangnt := w[j]/s[jj];
-             cosine := p5/sqrt(p25+p25*sqr(tangnt));
-                sine := cosine*tangnt;
-             tau := sine
-            End;
-            roo010(m-j+1, s[jj], 1, w[j], 1, cosine, sine);
-            w[j] := tau
-        End;
-       If (s[jj]=zero) Then sing := true;
-     inc(jj, m-j+1)
-    End;
-   If m>=n Then move(w[n], s[jj], (m-n+1)*sizeof(ArbFloat));
-   If s[jj]=zero Then sing := true
-End;
-
-Procedure roo013(fcn: roofnrfunc; n: ArbInt; Var x1, fvec1: ArbFloat;
-                 xtol: ArbFloat; maxfev, ml, mu: ArbInt; epsfcn: ArbFloat;
-                 Var diag1: ArbFloat; factor: ArbFloat; Var info: ArbInt;
-                 Var fjac1: ArbFloat; ldfjac: ArbInt;
-                 Var r1: ArbFloat; lr: ArbInt; Var qtf1: ArbFloat);
-
-Const p1 = 0.1;
- p5 = 0.5;
- p001 = 0.001;
- p0001 = 0.0001;
-
-Var  diag : arfloat1 absolute diag1;
-     fjac : arfloat1 absolute fjac1;
-     fvec : arfloat1 absolute fvec1;
-     qtf  : arfloat1 absolute qtf1;
-     r    : arfloat1 absolute r1;
-     wa1, wa2, wa3, wa4: ^arfloat1;
-     x    : arfloat1 absolute x1;
-     actred, delta, fnorm, fnorm1, pnorm,
-     prered, ratio, sum, temp, xnorm : ArbFloat;
-     i, iflag, iter, j, jm1, l, msum, ncfail, ncsuc, nfev,
-     nslow1, nslow2, ns : ArbInt;
-     jeval, sing, deff: boolean;
-Begin
-    info := 1;
- iflag := 0;
- nfev := 0;
- ns := n*sizeof(ArbFloat);
-    For j:=1 To n Do
-     If diag[j]<=0 Then exit;
-    iflag := 1;
- deff := true;
- fcn(x1, fvec1, deff);
-    If Not deff Then iflag := -1;
- nfev := 1;
-    If iflag<0 Then
-     Begin
-        info := iflag;
-      exit
-     End;
-    fnorm := norm2(n, fvec1, 1);
-    msum := ml+mu+1;
- If msum>n Then msum := n;
-    getmem(wa1, ns);
- getmem(wa2, ns);
- getmem(wa3, ns);
- getmem(wa4, ns);
-    iter := 1;
- ncsuc := 0;
- ncfail := 0;
- nslow1 := 0;
- nslow2 := 0;
-    while (info=1) and (iflag>=0) Do
-    Begin
-        jeval := true;
-     iflag := 2;
-        roo005(fcn, n, x1, fvec1, fjac1, ldfjac, iflag, ml, mu, epsfcn,
-               wa1^, wa2^);
-        inc(nfev, msum);
-        If iflag>=0 Then
-         Begin
-            roo009(n, fjac1, ldfjac, wa1^[1], wa2^[1]);
-            If iter=1 Then
-             Begin
-                For j:=1 To n Do
-                 wa3^[j] := diag[j]*x[j];
-                xnorm := norm2(n, wa3^[1], 1);
-                delta := factor*xnorm;
-                If delta=0 Then delta := factor;
-             End;
-             For i:=1 To n Do
-              qtf[i] := fvec[i];
-             For j:=1 To n Do
-              If fjac[j+(j-1)*ldfjac]<>0 Then
-               Begin
-                sum := 0;
-                For i:=j To n Do
-                 sum := sum+fjac[j+(i-1)*ldfjac]*qtf[i];
-                temp := -sum/fjac[j+(j-1)*ldfjac];
-                For i:=j To n Do
-                 qtf[i] := qtf[i]+fjac[j+(i-1)*ldfjac]*temp
-               End;
-             sing := false;
-             For j:=1 To n Do
-              Begin
-                l := j;
-               jm1 := j-1;
-                For i:=1 To jm1 Do
-                 Begin
-                   r[l] := fjac[j+(i-1)*ldfjac];
-                  inc(l, n-i)
-                 End;
-                r[l] := wa1^[j];
-                If wa1^[j]=0 Then sing := true
-              End;
-             roo008(n, fjac1, ldfjac, wa1^);
-             Repeat
-                roo004(n, r1, diag1, qtf1, delta, wa1^[1]);
-                For j:=1 To n Do
-                 Begin
-                   wa1^[j] := -wa1^[j];
-                  wa2^[j] := x[j]+wa1^[j];
-                   wa3^[j] := diag[j]*wa1^[j]
-                 End;
-                pnorm := norm2(n, wa3^[1], 1);
-                If iter=1 Then If pnorm<delta Then delta := pnorm;
-                iflag := 1;
-                deff := true;
-                fcn(wa2^[1], wa4^[1], deff);
-                If Not deff Then iflag := -1;
-                inc(nfev);
-                If iflag>0 Then
-                 Begin
-                   fnorm1 := norm2(n, wa4^[1], 1);
-                   If fnorm1<fnorm Then actred := 1-sqr(fnorm1/fnorm)
-                   Else actred := -1;
-                   move(wa1^, wa3^, n*sizeof(ArbFloat));
-                   roo001('l','t','n', n, r1, wa3^[1], 1);
-                   For i:=1 To n Do
-                    wa3^[i] := wa3^[i] + qtf[i];
-                   temp := norm2(n, wa3^[1], 1);
-                   If temp<fnorm
-                    Then prered := 1 - sqr(temp/fnorm)
-                   Else prered := 1;
-                   If prered>0 Then ratio := actred/prered
-                  Else ratio := 0;
-                   If ratio<p1 Then
-                    Begin
-                      ncsuc := 0;
-                     inc(ncfail);
-                     delta := p5*delta
-                    End
-                  Else
-                   Begin
-                      ncfail := 0;
-                    inc(ncsuc);
-                      If (ratio>=p5) Or (ncsuc>1)
-                       Then If delta<pnorm/p5 Then delta := pnorm/p5;
-                      If abs(ratio-1)<=p1 Then delta := pnorm/p5
-                   End;
-                   If ratio>=p0001 Then
-                    Begin
-                      For j:=1 To n Do
-                       Begin
-                          x[j] := wa2^[j];
-                        wa2^[j] := diag[j]*x[j];
-                          fvec[j] := wa4^[j]
-                       End;
-                      xnorm := norm2(n, wa2^[1], 1);
-                     fnorm := fnorm1;
-                     inc(iter)
-                    End;
-                   inc(nslow1);
-                   If actred>=p001 Then nslow1 := 0;
-                   If jeval Then inc(nslow2);
-                   If actred>=p1 Then nslow2 := 0;
-                   If (delta<=xtol*xnorm) Or
-                      (fnorm=0) Or (pnorm=0) Then info := 0
-                   Else If nfev>=maxfev Then info := 2
-                        Else If delta<=macheps*xnorm Then info := 3
-                             Else If nslow2=5 Then info := 4
-                                  Else If nslow1=10 Then info := 5;
-                   If (info=1) And (ncfail<>2) Then
-                    Begin
-                      roo006('t', n, n, 1, fjac1, ldfjac, wa4^[1], 1, 0,
-                              wa2^[1], 1);
-                      If ratio>=p0001 Then move(wa2^, qtf, ns);
-                      For j:=1 To n Do
-                       Begin
-                         wa2^[j] := (wa2^[j]-wa3^[j])/pnorm;
-                         wa1^[j] := diag[j]*((diag[j]*wa1^[j])/pnorm)
-                       End;
-                      roo012(n, n, r1, lr, wa1^[1], wa2^[1], wa3^[1], sing);
-                      roo011(n, n, fjac1, ldfjac, wa2^[1], wa3^[1]);
-                      roo011(1, n, qtf1, 1, wa2^[1], wa3^[1]);
-                      jeval := false
-                    End
-                 End
-             Until (iflag<0) Or (ncfail=2) Or (info<>1)
-         End
-      End;
-   freemem(wa4, ns);
- freemem(wa3, ns);
- freemem(wa2, ns);
- freemem(wa1, ns);
-   If iflag<0 Then info := iflag;
-End;
-
-Procedure roofnr(f: roofnrfunc; n: ArbInt; Var x, residu: ArbFloat; re: ArbFloat;
-                 Var term: ArbInt);
-
-Var       j, lr, ns          : ArbInt;
-      wa1, wa2, wa3, wa4, fx : ^arfloat1;
-Begin
-    ns := n*sizeof(ArbFloat);
-    If n<=0 Then term := 3
- Else
-    Begin
-        If re<0 Then term := 3
-     Else
-        Begin
-            lr := (n*(n+1)) Div 2;
-            getmem(wa1, ns);
-         getmem(wa2, ns);
-         getmem(wa3, lr*sizeof(ArbFloat));
-            getmem(wa4, n*ns);
-         getmem(fx, ns);
-            For j:=1 To n Do
-             wa1^[j] := 1;
-            roo013(f, n, x, fx^[1], re, 200*(n+1), n-1, n-1, 0, wa1^[1],
-                   100.0, term, wa4^[1], n, wa3^[1], lr, wa2^[1]);
-            residu := Norm2(n, fx^[1], 1);
-            freemem(fx, ns);
-         freemem(wa4, n*ns);
-            freemem(wa3, lr*sizeof(ArbFloat));
-         freemem(wa2, ns);
-         freemem(wa1, ns);
-            If term<0 Then term := 6
-         Else
-            Case term Of
-             0: term := 1;
-             2: term := 4;
-             3: term := 2;
-             4, 5: term := 5;
-            End
-        End
-    End
-End;
-End.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:45  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:15  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/sle.pas

@@ -1,2294 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    !! modifies randseed, might not exactly work as TP version!!!
-
-    Solve set of linear equations of the type Ax=b, for generic, and a
-    variety of special matrices.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-{Solve set of linear equations of the type Ax=b, for generic, and a variety of
-special matrices.
-One (generic) function for overdetermined sets of this kind : slegls
-
-overdetermined are sets that look like this: (I don't know if I
-translated "overdetermined" right)
-
-    6   1  2  3     9
-    3   9  3  4     2
-   17  27 42 15    62
-   17  27 42 15    61
-
-The two bottom rows look much alike, which introduces a big uncertainty in the
-result, therefore these matrices need special treatment.
-
-All procedures have similar procedure with a "L" appended to the name. We
-didn't receive docs for those procedures. If you know what the difference is,
-please mail us }
-
-Unit sle;
-interface
-{$I DIRECT.INC}
-
-uses typ, omv;
-
-{solve for special tridiagonal matrices}
-Procedure sledtr(n: ArbInt; Var l, d, u, b, x: ArbFloat; Var term: ArbInt);
-
-{solve for generic bandmatrices}
-Procedure slegba(n, l, r: ArbInt;
-                 Var a, b, x, ca: ArbFloat; Var term:ArbInt);
-
-Procedure slegbal(n, l, r: ArbInt;
-                  Var a1; Var b1, x1, ca: ArbFloat; Var term: ArbInt);
-
-{generic solve for all matrices}
-Procedure slegen(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Procedure slegenl(    n: ArbInt;
-                  Var a1;
-                  Var b1, x1, ca: ArbFloat;
-                  Var term: ArbInt);
-
-{solve for overdetermined matrices, see unit comments}
-Procedure slegls(Var a: ArbFloat; m, n, rwidtha: ArbInt; Var b, x: ArbFloat;
-                 Var term: ArbInt);
-
-
-Procedure sleglsl(Var a1; m, n: ArbInt; Var b1, x1: ArbFloat;
-                  Var term: ArbInt);
-
-{Symmetrical positive definitive bandmatrices}
-Procedure slegpb(n, l: ArbInt; Var a, b, x, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Procedure slegpbl(n, l: ArbInt;
-                  Var a1; Var b1, x1, ca: ArbFloat; Var term: ArbInt);
-
-{Symmetrical positive definitive matrices}
-Procedure slegpd(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Procedure slegpdl(n: ArbInt; Var a1; Var b1, x1, ca: ArbFloat;
-                  Var term: ArbInt);
-
-{Symmetrical matrices}
-Procedure slegsy(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Procedure slegsyl(n: ArbInt; Var a1; Var b1, x1, ca: ArbFloat;
-                  Var term: ArbInt);
-
-{tridiagonal matrices}
-Procedure slegtr(n:ArbInt; Var l, d, u, b, x, ca: ArbFloat;
-                 Var term: ArbInt);
-
-implementation
-
-Uses DSL,MDT;
-
-{Here originally stood an exact copy of mdtgtr from unit mdt}
-{Here originally stood an exact copy of dslgtr from unit DSL}
-
-Procedure decomp(Var qr: ArbFloat; m, n, rwidthq: ArbInt; Var alpha: ArbFloat;
-                 Var pivot, term: ArbInt);
-
-Var  i, j, jbar, k, ns, ii        : ArbInt;
-     beta, sigma, alphak, qrkk, s : ArbFloat;
-     pqr, pal, y, sum             : ^arfloat1;
-     piv                          : ^arint1;
-
-Begin
-  term := 1;
-  pqr := @qr;
-  pal := @alpha;
-  piv := @pivot;
-  ns := n*sizeof(ArbFloat);
-  getmem(y, ns);
-  getmem(sum, ns);
-  For j:=1 To n Do
-    Begin
-      s := 0;
-      For i:=1 To m Do
-        s := s+sqr(pqr^[(i-1)*rwidthq+j]);
-      sum^[j] := s;
-      piv^[j] := j
-    End; {j}
-  For k:=1 To n Do
-    Begin
-      sigma := sum^[k];
-      jbar := k;
-      For j:=k+1 To n Do
-        If sigma < sum^[j] Then
-          Begin
-            sigma := sum^[j];
-           jbar := j
-          End;
-      If jbar <> k
-       Then
-        Begin
-          i := piv^[k];
-          piv^[k] := piv^[jbar];
-          piv^[jbar] := i;
-          sum^[jbar] := sum^[k];
-          sum^[k] := sigma;
-          For i:=1 To m Do
-            Begin
-              ii := (i-1)*rwidthq;
-              sigma := pqr^[ii+k];
-              pqr^[ii+k] := pqr^[ii+jbar];
-              pqr^[ii+jbar] := sigma
-            End; {i}
-        End; {column interchange}
-      sigma := 0;
-      For i:=k To m Do
-        sigma := sigma+sqr(pqr^[(i-1)*rwidthq+k]);
-      If sigma=0 Then
-        Begin
-          term := 2;
-          freemem(y, ns);
-          freemem(sum, ns);
-          exit
-        End;
-      qrkk := pqr^[(k-1)*rwidthq+k];
-      If qrkk < 0 Then
-        alphak := sqrt(sigma)
-      Else
-        alphak := -sqrt(sigma);
-      pal^[k] := alphak;
-      beta := 1/(sigma-qrkk*alphak);
-      pqr^[(k-1)*rwidthq+k] := qrkk-alphak;
-      For j:=k+1 To n Do
-        Begin
-          s := 0;
-          For i:=k To m Do
-            Begin
-              ii := (i-1)*rwidthq;
-              s := s+pqr^[ii+k]*pqr^[ii+j]
-            End; {i}
-          y^[j] := beta*s
-        End; {j}
-      For j:=k+1 To n Do
-        Begin
-          For i:=k To m Do
-            Begin
-              ii := (i-1)*rwidthq;
-              pqr^[ii+j] := pqr^[ii+j]-pqr^[ii+k]*y^[j]
-            End; {i}
-          sum^[j] := sum^[j]-sqr(pqr^[(k-1)*rwidthq+j])
-        End {j}
-    End; {k}
-  freemem(y, ns);
- freemem(sum, ns);
-End; {decomp}
-
-Procedure decomp1(Var qr1; m, n: ArbInt; Var alpha1: ArbFloat;
-                  Var pivot1, term: ArbInt);
-
-Var             i, j, jbar, k, ns : ArbInt;
-     beta, sigma, alphak, qrkk, s : ArbFloat;
-     qr                           : ar2dr1 absolute qr1;
-     alpha                        : arfloat1 absolute alpha1;
-     pivot                        : arint1 absolute pivot1;
-     y, sum                       : ^arfloat1;
-Begin
-  term := 1;
-  ns := n*sizeof(ArbFloat);
-  getmem(y, ns);
- getmem(sum, ns);
-  For j:=1 To n Do
-    Begin
-      s := 0;
-      For i:=1 To m Do
-       s := s+sqr(qr[i]^[j]);
-      sum^[j] := s;
-     pivot[j] := j
-    End; {j}
-  For k:=1 To n Do
-    Begin
-      sigma := sum^[k];
-     jbar := k;
-      For j:=k+1 To n Do
-        If sigma < sum^[j]
-         Then
-          Begin
-            sigma := sum^[j];
-           jbar := j
-          End;
-      If jbar <> k
-       Then
-        Begin
-          i := pivot[k];
-         pivot[k] := pivot[jbar];
-         pivot[jbar] := i;
-          sum^[jbar] := sum^[k];
-         sum^[k] := sigma;
-          For i:=1 To m Do
-            Begin
-              sigma := qr[i]^[k];
-             qr[i]^[k] := qr[i]^[jbar];
-              qr[i]^[jbar] := sigma
-            End; {i}
-        End; {column interchange}
-      sigma := 0;
-      For i:=k To m Do
-       sigma := sigma+sqr(qr[i]^[k]);
-      If sigma=0
-       Then
-        Begin
-          term := 2;
-         freemem(y, ns);
-         freemem(sum, ns);
-         exit
-        End;
-      qrkk := qr[k]^[k];
-      If qrkk < 0 Then alphak := sqrt(sigma)
-     Else alphak := -sqrt(sigma);
-      alpha[k] := alphak;
-      beta := 1/(sigma-qrkk*alphak);
-      qr[k]^[k] := qrkk-alphak;
-      For j:=k+1 To n Do
-        Begin
-          s := 0;
-         For i:=k To m Do
-          s := s+qr[i]^[k]*qr[i]^[j];
-         y^[j] := beta*s
-        End; {j}
-      For j:=k+1 To n Do
-        Begin
-          For i:=k To m Do
-           qr[i]^[j] := qr[i]^[j]-qr[i]^[k]*y^[j];
-          sum^[j] := sum^[j]-sqr(qr[k]^[j])
-        End {j}
-    End; {k}
-  freemem(y, ns);
- freemem(sum, ns);
-End; {decomp1}
-
-Procedure solve(Var qr: ArbFloat; m, n, rwidthq: ArbInt; Var alpha: ArbFloat;
-                Var pivot: ArbInt; Var r, y: ArbFloat);
-
-Var    i, j, ii            : ArbInt;
-       gamma, s            : ArbFloat;
-       pqr, pal, pr, py, z : ^arfloat1;
-       piv                 : ^arint1;
-Begin
-  pqr := @qr;
-  pal := @alpha;
-  piv := @pivot;
-  pr := @r;
-  py := @y;
-  getmem(z, n*sizeof(ArbFloat));
-  For j:=1 To n Do
-    Begin
-      gamma := 0;
-      For i:=j To m Do
-        gamma := gamma+pqr^[(i-1)*rwidthq+j]*pr^[i];
-      gamma := gamma/(pal^[j]*pqr^[(j-1)*rwidthq+j]);
-      For i:=j To m Do
-        pr^[i] := pr^[i]+gamma*pqr^[(i-1)*rwidthq+j]
-    End; {j}
-  z^[n] := pr^[n]/pal^[n];
-  For i:=n-1 Downto 1 Do
-    Begin
-      s := pr^[i];
-      ii := (i-1)*rwidthq;
-      For j:=i+1 To n Do
-        s := s-pqr^[ii+j]*z^[j];
-      z^[i] := s/pal^[i]
-    End; {i}
-  For i:=1 To n Do
-    py^[piv^[i]] := z^[i];
-  freemem(z, n*sizeof(ArbFloat));
-End; {solve}
-
-Procedure solve1(Var qr1; m, n: ArbInt; Var alpha1: ArbFloat;
-                 Var pivot1: ArbInt; Var r1, y1: ArbFloat);
-
-Var    i, j                : ArbInt;
-       gamma, s            : ArbFloat;
-       qr                  : ar2dr1 absolute qr1;
-       alpha               : arfloat1 absolute alpha1;
-       r                   : arfloat1 absolute r1;
-       y                   : arfloat1 absolute y1;
-       pivot               : arint1 absolute pivot1;
-       z                   : ^arfloat1;
-Begin
-  getmem(z, n*sizeof(ArbFloat));
-  For j:=1 To n Do
-    Begin
-      gamma := 0;
-      For i:=j To m Do
-       gamma := gamma+qr[i]^[j]*r[i];
-      gamma := gamma/(alpha[j]*qr[j]^[j]);
-      For i:=j To m Do
-       r[i] := r[i]+gamma*qr[i]^[j]
-    End; {j}
-  z^[n] := r[n]/alpha[n];
-  For i:=n-1 Downto 1 Do
-    Begin
-      s := r[i];
-      For j:=i+1 To n Do
-       s := s-qr[i]^[j]*z^[j];
-      z^[i] := s/alpha[i]
-    End; {i}
-  For i:=1 To n Do
-   y[pivot[i]] := z^[i];
-  freemem(z, n*sizeof(ArbFloat));
-End; {solve1}
-
-Procedure sledtr(n: ArbInt; Var l, d, u, b, x: ArbFloat; Var term: ArbInt);
-
-Var               i, j, sr : ArbInt;
-                    lj, di : ArbFloat;
-        pd, pu, pb, px, dd : ^arfloat1;
-                        pl : ^arfloat2;
-Begin
-  If n<1
-   Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  pl := @l;
- pd := @d;
- pu := @u;
- pb := @b;
- px := @x;
-  sr := sizeof(ArbFloat);
-  getmem(dd, n*sr);
-  move(pb^, px^, n*sr);
-  j := 1;
- di := pd^[j];
- dd^[j] := di;
-  If di=0
-   Then
-    term := 2
-  Else
-    term := 1;
-  while (term=1) and (j <> n) Do
-    Begin
-      i := j;
-     j := j+1;
-     lj := pl^[j]/di;
-      di := pd^[j]-lj*pu^[i];
-     dd^[j] := di;
-      If di=0
-       Then
-        term := 2
-      Else
-        px^[j] := px^[j]-lj*px^[i]
-    End; {j}
-  If term=1
-   Then
-    Begin
-      px^[n] := px^[n]/dd^[n];
-      For i:=n-1 Downto 1 Do
-        px^[i] := (px^[i]-pu^[i]*px^[i+1])/dd^[i]
-    End; {term=1}
-  freemem(dd, n*sr);
-End; {sledtr}
-
-Procedure slegba(n, l, r: ArbInt;
-                 Var a, b, x, ca: ArbFloat; Var term:ArbInt);
-
-Var
-  sr, i, j, k, ipivot, m, lbj, lbi, ubi, ls,
-         ii, jj, ll, s, js, ubj, rwidth       : ArbInt;
-  ra, normr, sumrowi, pivot, normt, maxim, h  : ArbFloat;
-  pa, pb, px, au, sumrow, t, row              : ^arfloat1;
-Begin
-  If (n<1) Or (l<0) Or (r<0) Or (l>n-1) Or (r>n-1)
-   Then
-    Begin
-      term := 3;
-     exit
-    End; {term=3}
-  sr := sizeof(ArbFloat);
-  pa := @a;
- pb := @b;
- px := @x;
-  ll := l+r+1;
-  ls := ll*sr;
-  getmem(au, ls*n);
-  getmem(sumrow, n*sr);
-  getmem(t, n*sr);
-  getmem(row, ls);
-  move(pb^, px^, n*sr);
-  jj := 1;
- ii := 1;
-  For i:=1 To n Do
-    Begin
-      If i <= l+1 Then
-        Begin
-          If i <= n-r Then rwidth := r+i
-         Else rwidth := n
-        End
-     Else
-          If i <= n-r Then rwidth := ll
-     Else rwidth := n-i+l+1;
-      move(pa^[jj], au^[ii], rwidth*sr);
-      fillchar(au^[ii+rwidth], (ll-rwidth)*sr, 0);
-      jj := jj+rwidth;
-     ii := ii+ll;
-    End; {i}
-  lbi := n-r+1;
- lbj := 0;
-  normr := 0;
- term := 1;
-  ii := 1;
-  For i:=1 To n Do
-    Begin
-      sumrowi := omvn1v(au^[ii], ll);
-      ii := ii+ll;
-      sumrow^[i] := sumrowi;
-      h := 2*random-1;
-     t^[i] := sumrowi*h;
-      h := abs(h);
-     If normr<h Then normr := h;
-      If sumrowi=0 Then term := 2
-    End; {i}
-  ubi := l;
- k := 0;
- jj := 1;
-  while (k<n) and (term=1) Do
-    Begin
-      maxim := 0;
-     k := k+1;
-     ipivot := k;
-     ii := jj;
-      If ubi<n
-       Then ubi := ubi+1;
-      For i:=k To ubi Do
-        Begin
-          sumrowi := sumrow^[i];
-          If sumrowi <> 0
-           Then
-            Begin
-              h := abs(au^[ii])/sumrowi;
-              ii := ii+ll;
-              If maxim<h
-               Then
-                Begin
-                  maxim := h;
-                 ipivot := i
-                End {maxim<h}
-            End {sumrowi <> 0}
-        End; {i}
-      If maxim=0
-       Then
-        term := 2
-      Else
-        Begin
-          If ipivot <> k
-           Then
-            Begin
-              ii := (ipivot-1)*ll+1;
-              move(au^[ii], row^, ls);
-              move(au^[jj], au^[ii], ls);
-              move(row^, au^[jj], ls);
-              h := t^[ipivot];
-             t^[ipivot] := t^[k];
-             t^[k] := h;
-              h := px^[ipivot];
-             px^[ipivot] := px^[k];
-             px^[k] := h;
-              sumrow^[ipivot] := sumrow^[k]
-            End; {ipivot <> k}
-          pivot := au^[jj];
-         ii := jj;
-          For i:=k+1 To ubi Do
-            Begin
-              ii := ii+ll;
-              h := au^[ii]/pivot;
-              For j:=0 To ll-2 Do
-                au^[ii+j] := au^[ii+j+1]-h*au^[jj+j+1];
-              au^[ii+ll-1] := 0;
-              t^[i] := t^[i]-h*t^[k];
-              px^[i] := px^[i]-h*px^[k];
-            End {i}
-        End; {maxim <> 0}
-        jj := jj+ll
-    End; {k}
-  If term=1
-   Then
-    Begin
-      normt := 0;
-     ubj := -l-1;
-      jj := n*ll+1;
-      For i:=n Downto 1 Do
-        Begin
-          jj := jj-ll;
-          If ubj<r
-           Then
-            ubj := ubj+1;
-          h := t^[i];
-          For j:=1 To ubj+l Do
-            h := h-au^[jj+j]*t^[i+j];
-          t^[i] := h/au^[jj];
-          h := px^[i];
-          For j:=1 To ubj+l Do
-            h := h-au^[jj+j]*px^[i+j];
-          px^[i] := h/au^[jj];
-          h := abs(t^[i]);
-          If normt<h
-           Then
-            normt := h
-        End; {i}
-        ca := normt/normr
-    End; {term=1}
-  freemem(au, ls*n);
-  freemem(sumrow, n*sr);
-  freemem(t, n*sr);
-  freemem(row, ls)
-End; {slegba}
-
-Procedure slegbal(n, l, r: ArbInt;
-                  Var a1; Var b1, x1, ca: ArbFloat; Var term:ArbInt);
-
-Var 
-  sr, i, j, k, ipivot, m, lbj, lbi, ubi, ls,
-                 ll, s, js, ubj, rwidth       : ArbInt;
-  ra, normr, sumrowi, pivot, normt, maxim, h  : ArbFloat;
-  a                                           : ar2dr1 absolute a1;
-  b                                           : arfloat1 absolute b1;
-  x                                           : arfloat1 absolute x1;
-  au                                          : par2dr1;
-  sumrow, t, row                              : ^arfloat1;
-Begin
-  If (n<1) Or (l<0) Or (r<0) Or (l>n-1) Or (r>n-1)
-   Then
-    Begin
-      term := 3;
-     exit
-    End; {term=3}
-  sr := sizeof(ArbFloat);
- ll := l+r+1;
- ls := ll*sr;
-  AllocateAr2dr(n, ll, au);
-  getmem(sumrow, n*sr);
- getmem(t, n*sr);
- getmem(row, ls);
-  move(b[1], x[1], n*sr);
-  For i:=1 To n Do
-    Begin
-      If i <= l+1 Then
-        Begin
-          If i <= n-r Then rwidth := r+i
-         Else rwidth := n
-        End
-     Else
-          If i <= n-r Then rwidth := ll
-     Else rwidth := n-i+l+1;
-      move(a[i]^, au^[i]^, rwidth*sr);
-      fillchar(au^[i]^[rwidth+1], (ll-rwidth)*sr, 0);
-    End; {i}
-  normr := 0;
- term := 1;
-  For i:=1 To n Do
-    Begin
-      sumrowi := omvn1v(au^[i]^[1], ll);
-     sumrow^[i] := sumrowi;
-      h := 2*random-1;
-     t^[i] := sumrowi*h;
-      h := abs(h);
-     If normr<h Then normr := h;
-      If sumrowi=0 Then term := 2
-    End; {i}
-  ubi := l;
- k := 0;
-  while (k<n) and (term=1) Do
-    Begin
-      maxim := 0;
-     k := k+1;
-     ipivot := k;
-      If ubi<n Then ubi := ubi+1;
-      For i:=k To ubi Do
-        Begin
-          sumrowi := sumrow^[i];
-          If sumrowi <> 0 Then
-            Begin
-              h := abs(au^[i]^[1])/sumrowi;
-              If maxim<h Then
-                Begin
-                  maxim := h;
-                 ipivot := i
-                End {maxim<h}
-            End {sumrowi <> 0}
-        End; {i}
-      If maxim=0 Then term := 2
-     Else
-        Begin
-          If ipivot <> k Then
-            Begin
-              move(au^[ipivot]^, row^, ls);
-              move(au^[k]^, au^[ipivot]^, ls);
-              move(row^, au^[k]^, ls);
-              h := t^[ipivot];
-             t^[ipivot] := t^[k];
-             t^[k] := h;
-              h := x[ipivot];
-             x[ipivot] := x[k];
-             x[k] := h;
-              sumrow^[ipivot] := sumrow^[k]
-            End; {ipivot <> k}
-          pivot := au^[k]^[1];
-          For i:=k+1 To ubi Do
-            Begin
-              h := au^[i]^[1]/pivot;
-              For j:=0 To ll-2 Do
-                au^[i]^[j+1] := au^[i]^[j+2]-h*au^[k]^[j+2];
-              au^[i]^[ll] := 0;
-              t^[i] := t^[i]-h*t^[k];
-              x[i] := x[i]-h*x[k];
-            End {i}
-        End; {maxim <> 0}
-    End; {k}
-  If term=1 Then
-    Begin
-      normt := 0;
-     ubj := -l-1;
-      For i:=n Downto 1 Do
-        Begin
-          If ubj<r Then ubj := ubj+1;
-          h := t^[i];
-          For j:=1 To ubj+l Do
-           h := h-au^[i]^[j+1]*t^[i+j];
-          t^[i] := h/au^[i]^[1];
-          h := x[i];
-          For j:=1 To ubj+l Do
-           h := h-au^[i]^[j+1]*x[i+j];
-          x[i] := h/au^[i]^[1];
-          h := abs(t^[i]);
-         If normt<h Then normt := h
-        End; {i}
-        ca := normt/normr
-    End; {term=1}
-  freemem(sumrow, n*sr);
- freemem(t, n*sr);
- freemem(row, ls);
-  DeAllocateAr2dr(n, ll, au);
-End; {slegbal}
-
-Procedure slegen(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Var 
-          nsr, i, j, k, ipiv, ip, ik, i1n, k1n : ArbInt;
-                                      singular : boolean;
-           normr, pivot, l, normt, maxim, h, s : ArbFloat;
-                pa, px, pb, au, sumrow, t, row : ^arfloat1;
-
-Begin
-  If (n<1) Or (rwidth<1)
-   Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  getmem(au, sqr(n)*sizeof(ArbFloat));
-  nsr := n*sizeof(ArbFloat);
-  getmem(t, nsr);
-  getmem(row, nsr);
-  getmem(sumrow, nsr);
-  pa := @a;
- pb := @b;
- px := @x;
-  For i:= 1 To n Do
-    move(pa^[1+(i-1)*rwidth], au^[1+(i-1)*n], nsr);
-  move(pb^[1], px^[1], nsr);
-  normr := 0;
- singular := false ;
- i := 0;
- j := 0;
-  while (i<n) and  (Not singular) Do
-    Begin
-      i := i+1;
-     sumrow^[i] := omvn1v(au^[1+(i-1)*n], n);
-      If sumrow^[i]=0
-       Then
-        singular := true
-      Else
-        Begin
-          h := 2*random-1;
-         t^[i] := sumrow^[i]*h;
-         h := abs(h);
-          If normr<h
-           Then
-            normr := h
-        End
-    End;
-  k := 0;
-  while (k<n) and  not singular Do
-    Begin
-      k := k+1;
-     maxim := 0;
-     ipiv := k;
-      For i:=k To n Do
-        Begin
-          h := abs(au^[k+(i-1)*n])/sumrow^[i];
-          If maxim<h
-           Then
-            Begin
-              maxim := h;
-             ipiv := i
-            End
-        End;
-      If maxim=0
-       Then
-        singular := true
-      Else
-        Begin
-          k1n := (k-1)*n;
-          If ipiv <> k
-           Then
-            Begin
-              ip := 1+(ipiv-1)*n;
-             ik := 1+k1n;
-              move(au^[ip], row^[1], nsr);
-             move(au^[ik], au^[ip], nsr);
-              move(row^[1], au^[ik], nsr);
-              h := t^[ipiv];
-             t^[ipiv] := t^[k];
-             t^[k] := h;
-              h := px^[ipiv];
-             px^[ipiv] := px^[k];
-             px^[k] := h;
-              sumrow^[ipiv] := sumrow^[k]
-            End;
-          pivot := au^[k+k1n];
-          For i:=k+1 To n Do
-            Begin
-              i1n := (i-1)*n;
-             l := au^[k+i1n]/pivot;
-              If l <> 0
-               Then
-                Begin
-                  For j:=k+1 To n Do
-                    au^[j+i1n] := au^[j+i1n]-l*au^[j+k1n];
-                  t^[i] := t^[i]-l*t^[k];
-                  px^[i] := px^[i]-l*px^[k]
-                End
-            End
-        End
-    End;
-  If  Not singular
-   Then
-    Begin
-      normt := 0;
-      For i:=n Downto 1 Do
-        Begin
-          s := 0;
-         i1n := (i-1)*n;
-          For j:=i+1 To n Do
-            s := s+t^[j]*au^[j+i1n];
-          t^[i] := (t^[i]-s)/au^[i+i1n];
-          s := 0;
-          For j:=i+1 To n Do
-            s := s+px^[j]*au^[j+i1n];
-          px^[i] := (px^[i]-s)/au^[i+i1n];
-          h := abs(t^[i]);
-          If normt<h
-           Then
-            normt := h
-        End;
-      ca := normt/normr
-    End;
-   If singular
-    Then
-     term := 2
-   Else
-     term := 1;
-  freemem(au, sqr(n)*sizeof(ArbFloat));
-  freemem(t, nsr);
-  freemem(row, nsr);
-  freemem(sumrow, nsr);
-End; {slegen}
-
-Procedure slegenl(     n: ArbInt;
-                  Var a1;
-                  Var b1, x1, ca: ArbFloat;
-                  Var term: ArbInt);
-
-Var 
-     nsr, i, j, k, ipiv : ArbInt;
-               singular : boolean;
-     normr, pivot, l, normt, maxim, h, s : ArbFloat;
-     a : ar2dr1 absolute a1;
-     x : arfloat1 absolute x1;
-     b : arfloat1 absolute b1;
-     au: par2dr1;
-     sumrow, t, row : ^arfloat1;
-Begin
-  If n<1 Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  AllocateAr2dr(n, n, au);
-  nsr := n*sizeof(ArbFloat);
-  getmem(t, nsr);
-  getmem(row, nsr);
-  getmem(sumrow, nsr);
-  For i:= 1 To n Do
-   move(a[i]^, au^[i]^, nsr);
-  move(b[1], x[1], nsr);
-  normr := 0;
- singular := false ;
- i := 0;
- j := 0;
-  while (i<n) and  (Not singular) Do
-    Begin
-      i := i+1;
-     sumrow^[i] := omvn1v(au^[i]^[1], n);
-      If sumrow^[i]=0
-       Then
-        singular := true
-      Else
-        Begin
-          h := 2*random-1;
-         t^[i] := sumrow^[i]*h;
-         h := abs(h);
-          If normr<h
-           Then
-            normr := h
-        End
-    End;
-  k := 0;
-  while (k<n) and  not singular Do
-    Begin
-      k := k+1;
-     maxim := 0;
-     ipiv := k;
-      For i:=k To n Do
-        Begin
-          h := abs(au^[i]^[k])/sumrow^[i];
-          If maxim<h
-           Then
-            Begin
-              maxim := h;
-             ipiv := i
-            End
-        End;
-      If maxim=0
-       Then
-        singular := true
-      Else
-        Begin
-          If ipiv <> k
-           Then
-            Begin
-              move(au^[ipiv]^, row^, nsr);
-              move(au^[k]^, au^[ipiv]^, nsr);
-              move(row^, au^[k]^, nsr);
-              h := t^[ipiv];
-             t^[ipiv] := t^[k];
-             t^[k] := h;
-              h := x[ipiv];
-             x[ipiv] := x[k];
-             x[k] := h;
-              sumrow^[ipiv] := sumrow^[k]
-            End;
-          pivot := au^[k]^[k];
-          For i:=k+1 To n Do
-            Begin
-              l := au^[i]^[k]/pivot;
-              If l <> 0
-               Then
-                Begin
-                  For j:=k+1 To n Do
-                    au^[i]^[j] := au^[i]^[j]-l*au^[k]^[j];
-                  t^[i] := t^[i]-l*t^[k];
-                  x[i] := x[i]-l*x[k]
-                End
-            End
-        End
-    End;
-  If  Not singular
-   Then
-    Begin
-      normt := 0;
-      For i:=n Downto 1 Do
-        Begin
-          s := 0;
-          For j:=i+1 To n Do
-            s := s+t^[j]*au^[i]^[j];
-          t^[i] := (t^[i]-s)/au^[i]^[i];
-          s := 0;
-          For j:=i+1 To n Do
-            s := s+x[j]*au^[i]^[j];
-          x[i] := (x[i]-s)/au^[i]^[i];
-          h := abs(t^[i]);
-          If normt<h
-           Then
-            normt := h
-        End;
-      ca := normt/normr
-    End;
-   If singular
-    Then
-     term := 2
-   Else
-     term := 1;
-  freemem(t, nsr);
-  freemem(row, nsr);
-  freemem(sumrow, nsr);
-  DeAllocateAr2dr(n, n, au);
-End; {slegenl}
-
-Procedure slegls(Var a: ArbFloat; m, n, rwidtha: ArbInt; Var b, x: ArbFloat;
-                 Var term: ArbInt);
-
-Var     i, j, ns, ms, ii                : ArbInt;
-        normy0, norme0, norme1, s       : ArbFloat;
-        pa, pb, px, qr, alpha, e, y, r  : ^arfloat1;
-        pivot                           : ^arint1;
-Begin
-  If (n<1) Or (m<n)
-   Then
-    Begin
-      term := 3;
-     exit
-    End;
-  pa := @a;
- pb := @b;
- px := @x;
-  ns := n*sizeof(ArbFloat);
- ms := m*sizeof(ArbFloat);
-  getmem(qr, m*ns);
- getmem(alpha, ns);
- getmem(e, ns);
- getmem(y, ns);
-  getmem(r, m*sizeof(ArbFloat));
- getmem(pivot, n*sizeof(ArbInt));
-  For i:=1 To m Do
-    move(pa^[(i-1)*rwidtha+1], qr^[(i-1)*n+1], ns);
-  decomp(qr^[1], m, n, n, alpha^[1], pivot^[1], term);
-  If term=2
-   Then
-    Begin
-      freemem(qr, m*ns);
-     freemem(alpha, ns);
-     freemem(e, ns);
-     freemem(y, ns);
-      freemem(r, m*sizeof(ArbFloat));
-     freemem(pivot, n*sizeof(ArbInt));
-      exit
-    End;
-  move(pb^[1], r^[1], ms);
-  solve(qr^[1], m, n, n, alpha^[1], pivot^[1], r^[1], y^[1]);
-  For i:=1 To m Do
-    Begin
-      s := pb^[i];
-     ii := (i-1)*rwidtha;
-      For j:=1 To n Do
-        s := s-pa^[ii+j]*y^[j];
-      r^[i] := s
-    End; {i}
-  solve(qr^[1], m, n, n, alpha^[1], pivot^[1], r^[1], e^[1]);
-  normy0 := 0;
- norme1 := 0;
-  For i:=1 To n Do
-    Begin
-      normy0 := normy0+sqr(y^[i]);
-     norme1 := norme1+sqr(e^[i])
-    End; {i}
-  If norme1 > 0.0625*normy0
-   Then
-    Begin
-      term := 2;
-      freemem(qr, m*ns);
-     freemem(alpha, ns);
-     freemem(e, ns);
-     freemem(y, ns);
-      freemem(r, m*sizeof(ArbFloat));
-     freemem(pivot, n*sizeof(ArbInt));
-      exit
-    End;
-  For i:=1 To n Do
-    px^[i] := y^[i];
-  freemem(qr, m*ns);
- freemem(alpha, ns);
- freemem(e, ns);
- freemem(y, ns);
-  freemem(r, m*sizeof(ArbFloat));
- freemem(pivot, n*sizeof(ArbInt));
-End; {slegls}
-
-Procedure sleglsl(Var a1; m, n: ArbInt; Var b1, x1: ArbFloat;
-                  Var term: ArbInt);
-
-Var     i, j, ns, ms                    : ArbInt;
-        normy0, norme0, norme1, s       : ArbFloat;
-        a                               : ar2dr1 absolute a1;
-        b                               : arfloat1 absolute b1;
-        x                               : arfloat1 absolute x1;
-        alpha, e, y, r                  : ^arfloat1;
-        qr                              : par2dr1;
-        pivot                           : ^arint1;
-Begin
-  If (n<1) Or (m<n)
-   Then
-    Begin
-      term := 3;
-     exit
-    End;
-  AllocateAr2dr(m, n, qr);
-  ns := n*sizeof(ArbFloat);
- ms := m*sizeof(ArbFloat);
-  getmem(alpha, ns);
- getmem(e, ns);
- getmem(y, ns);
-  getmem(r, ms);
- getmem(pivot, n*sizeof(ArbInt));
-  For i:=1 To m Do
-    move(a[i]^, qr^[i]^, ns);
-  decomp1(qr^[1], m, n, alpha^[1], pivot^[1], term);
-  If term=2
-   Then
-    Begin
-      freemem(qr, m*ns);
-     freemem(alpha, ns);
-     freemem(e, ns);
-     freemem(y, ns);
-      freemem(r, ms);
-     freemem(pivot, n*sizeof(ArbInt));
-      exit
-    End;
-  move(b[1], r^, ms);
-  solve1(qr^[1], m, n, alpha^[1], pivot^[1], r^[1], y^[1]);
-  For i:=1 To m Do
-    Begin
-      s := b[i];
-      For j:=1 To n Do
-       s := s-a[i]^[j]*y^[j];
-      r^[i] := s
-    End; {i}
-  solve1(qr^[1], m, n, alpha^[1], pivot^[1], r^[1], e^[1]);
-  normy0 := 0;
- norme1 := 0;
-  For i:=1 To n Do
-    Begin
-      normy0 := normy0+sqr(y^[i]);
-     norme1 := norme1+sqr(e^[i])
-    End; {i}
-  If norme1 > 0.0625*normy0
-   Then
-    Begin
-      term := 2;
-      freemem(qr, m*ns);
-     freemem(alpha, ns);
-     freemem(e, ns);
-     freemem(y, ns);
-      freemem(r, m*sizeof(ArbFloat));
-     freemem(pivot, n*sizeof(ArbInt));
-      exit
-    End;
-  For i:=1 To n Do
-   x[i] := y^[i];
-  freemem(alpha, ns);
- freemem(e, ns);
- freemem(y, ns);
-  freemem(r, ms);
- freemem(pivot, n*sizeof(ArbInt));
-  DeAllocateAr2dr(m, n, qr);
-End; {sleglsl}
-
-Procedure slegpb(n, l: ArbInt; Var a, b, x, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Var
-    posdef                                                 : boolean;
-    i, j, k, r, p, q, jmin1, ii, jj, ri, ind,
-                                      ll, llm1, sr, rwidth : ArbInt;
-    h, normr, normt, sumrowi, hh, alim, norma              : ArbFloat;
-    pa, pb, px, al, t, v                                   : ^arfloat1;
-
-    Procedure decomp(i, r: ArbInt);
-
-    Var k: ArbInt;
-    Begin
-      ri := (r-1)*ll;
-      h := al^[ii+j];
-     q := ll-j+p;
-      For k:=p To jmin1 Do
-        Begin
-          h := h-al^[ii+k]*al^[ri+q];
-         q := q+1
-        End ;
-      If j<ll
-       Then
-        al^[ii+j] := h/al^[ri+ll];
-    End; {decomp}
-
-Begin
-  If (n<1) Or (l<0) Or (l>n-1)
-   Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  sr := sizeof(ArbFloat);
-  pa := @a;
-  pb := @b;
-  px := @x;
-  ll := l+1;
-  getmem(al, ll*n*sr);
-  getmem(t, n*sr);
-  getmem(v, ll*sr);
-  move(pb^, px^, n*sr);
-  jj := 1;
-  ii := 1;
-  For i:=1 To n Do
-    Begin
-      If i>l Then rwidth := ll
-     Else rwidth := i;
-      move(pa^[jj], al^[ii+ll-rwidth], rwidth*sr);
-      jj := jj+rwidth;
-     ii := ii+ll
-    End; {i}
-  normr := 0;
- p := ll+1;
- norma := 0;
-  For i:=1 To n Do
-    Begin
-      If p>1
-       Then
-        p := p-1;
-      For j:=p To ll Do
-        v^[j] := al^[j+(i-1)*ll];
-      sumrowi := omvn1v(v^[p], ll-p+1);
-      r := i;
-     j := ll;
-      while (r<n) and (j>1) Do
-        Begin
-          r := r+1;
-         j := j-1;
-          sumrowi := sumrowi+abs(al^[j+(r-1)*ll])
-        End; {r,j}
-      If norma<sumrowi
-       Then
-        norma := sumrowi;
-      h := 2*random-1;
-     t^[i] := h;
-      h := abs(h);
-      If normr<h
-       Then
-        normr := h
-    End; {i}
-  llm1 := ll-1;
- p := ll+1;
- i := 0;
- posdef := true ;
-  while (i<n) and posdef Do
-    Begin
-      i := i+1;
-     If p>1 Then p := p-1;
-     r := i-ll+p;
-     j := p-1;
-      ii := (i-1)*ll;
-      while j<llm1 Do
-        Begin
-          jmin1 := j;
-         j := j+1;
-          decomp(i, r);
-          r := r+1
-        End ; {j}
-      jmin1 := llm1;
-     j := ll;
-      decomp(i, i);
-      If h <= 0
-       Then
-        posdef := false
-      Else
-        Begin
-          alim := sqrt(h);
-         al^[ii+ll] := alim;
-          h := t^[i];
-         q := i;
-          For k:=llm1 Downto p Do
-            Begin
-              q := q-1;
-             h := h-al^[ii+k]*t^[q]
-            End ;
-          t^[i] := h/alim;
-          h := px^[i];
-         q := i;
-          For k:=llm1 Downto p Do
-            Begin
-              q := q-1;
-             h := h-al^[ii+k]*px^[q]
-            End; {k}
-          px^[i] := h/alim
-        End {posdef}
-    End; {i}
-    If posdef
-     Then
-      Begin
-        normt := 0;
-       p := ll+1;
-        For i:=n Downto 1 Do
-          Begin
-            If p>1
-             Then
-              p := p-1;
-            q := i;
-           h := t^[i];
-           hh := px^[i];
-            For k:=llm1 Downto p Do
-              Begin
-                q := q+1;
-                ind := (q-1)*ll+k;
-                h := h-al^[ind]*t^[q];
-               hh := hh-al^[ind]*px^[q]
-              End; {k}
-            ind := i*ll;
-            t^[i] := h/al^[ind];
-           px^[i] := hh/al^[ind];
-            h := abs(t^[i]);
-            If normt<h
-             Then
-              normt := h
-         End; {i}
-       ca := norma*normt/normr
-     End ; {posdef}
-  If posdef
-   Then
-    term := 1
-  Else
-    term := 2;
-  freemem(al, ll*n*sr);
-  freemem(t, n*sr);
-  freemem(v, ll*sr);
-End;  {slegpb}
-
-Procedure slegpbl(n, l: ArbInt;
-                  Var a1; Var b1, x1, ca: ArbFloat; Var term: ArbInt);
-
-Var 
-    posdef                                    : boolean;
-    i, j, k, r, p, q, ll, sr, rwidth          : ArbInt;
-    h, normr, normt, sumrowi, hh, alim, norma : ArbFloat;
-    a                                         : ar2dr1 absolute a1;
-    b                                         : arfloat1 absolute b1;
-    x                                         : arfloat1 absolute x1;
-    al                                        : par2dr1;
-    t, v                                      : ^arfloat1;
-
-    Procedure decomp(r: ArbInt);
-
-    Var k: ArbInt;
-    Begin
-      h := al^[i]^[j];
-     q := ll-j+p;
-      For k:=p To j-1 Do
-        Begin
-          h := h-al^[i]^[k]*al^[r]^[q];
-         Inc(q)
-        End ;
-      If j<ll Then al^[i]^[j] := h/al^[r]^[ll];
-    End; {decomp}
-
-Begin
-  If (n<1) Or (l<0) Or (l>n-1)
-   Then
-    Begin
-      term := 3;
-     exit
-    End; {wrong input}
-  sr := sizeof(ArbFloat);
-  ll := l+1;
-  AllocateAr2dr(n, ll, al);
-  getmem(t, n*sr);
- getmem(v, ll*sr);
-  move(b[1], x[1], n*sr);
-  For i:=1 To n Do
-    Begin
-      If i>l Then rwidth := ll
-     Else rwidth := i;
-      move(a[i]^, al^[i]^[ll-rwidth+1], rwidth*sr);
-    End; {i}
-  normr := 0;
- p := ll+1;
- norma := 0;
-  For i:=1 To n Do
-    Begin
-      If p>1 Then Dec(p);
-      For j:=p To ll Do
-       v^[j] := al^[i]^[j];
-      sumrowi := omvn1v(v^[p], ll-p+1);
-      r := i;
-     j := ll;
-      while (r<n) and (j>1) Do
-        Begin
-          Inc(r);
-         Dec(j);
-          sumrowi := sumrowi+abs(al^[r]^[j])
-        End; {r,j}
-      If norma<sumrowi Then norma := sumrowi;
-      h := 2*random-1;
-     t^[i] := h;
-      h := abs(h);
-     If normr<h Then normr := h
-    End; {i}
-  p := ll+1;
- i := 0;
- posdef := true ;
-  while (i<n) and posdef Do
-    Begin
-      Inc(i);
-     If p>1 Then Dec(p);
-     r := i-ll+p;
-     j := p-1;
-      while j<ll-1 Do
-        Begin
-          Inc(j);
-         decomp(r);
-         Inc(r)
-        End ; {j}
-      j := ll;
-     decomp(i);
-      If h <= 0 Then posdef := false
-     Else
-        Begin
-          alim := sqrt(h);
-         al^[i]^[ll] := alim;
-          h := t^[i];
-         q := i;
-          For k:=ll-1 Downto p Do
-            Begin
-              q := q-1;
-             h := h-al^[i]^[k]*t^[q]
-            End ;
-          t^[i] := h/alim;
-          h := x[i];
-         q := i;
-          For k:=ll-1 Downto p Do
-            Begin
-              q := q-1;
-             h := h-al^[i]^[k]*x[q]
-            End; {k}
-          x[i] := h/alim
-        End {posdef}
-    End; {i}
-    If posdef
-     Then
-      Begin
-        normt := 0;
-       p := ll+1;
-        For i:=n Downto 1 Do
-          Begin
-            If p>1 Then Dec(p);
-            q := i;
-           h := t^[i];
-           hh := x[i];
-            For k:=ll-1 Downto p Do
-              Begin
-                Inc(q);
-                h := h-al^[q]^[k]*t^[q];
-               hh := hh-al^[q]^[k]*x[q]
-              End; {k}
-            t^[i] := h/al^[i]^[ll];
-           x[i] := hh/al^[i]^[ll];
-            h := abs(t^[i]);
-           If normt<h Then normt := h
-         End; {i}
-       ca := norma*normt/normr
-     End ; {posdef}
-  If posdef Then term := 1
- Else term := 2;
-  freemem(t, n*sr);
- freemem(v, ll*sr);
-  DeAllocateAr2dr(n, ll, al);
-End;  {slegpbl}
-
-Procedure slegpd(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Var 
-    sr, i, j, k, kmin1, kk, k1n, i1n, ik, ii : ArbInt;
-                                          pd : boolean;
-        h, lkk, normr, normt, sumrowi, norma : ArbFloat;
-                           pa, pb, px, al, t : ^arfloat1;
-
-Begin
-  If (n<1) Or (rwidth<1)
-   Then
-    Begin
-      term := 3;
-     exit
-    End;
-  sr := sizeof(ArbFloat);
-  getmem(al, sqr(n)*sr);
- getmem(t, n*sr);
-  pa := @a;
- pb := @b;
- px := @x;
-  For i:=1 To n Do
-    move(pa^[1+(i-1)*rwidth], al^[1+(i-1)*n], i*sr);
-  move(pb^[1], px^[1], n*sr);
-  normr := 0;
- pd := true ;
- norma := 0;
-  For i:=1 To n Do
-    Begin
-      sumrowi := 0;
-      For j:=1 To i Do
-        sumrowi := sumrowi+abs(al^[j+(i-1)*n]);
-      For j:=i+1 To n Do
-        sumrowi := sumrowi+abs(al^[i+(j-1)*n]);
-      If norma<sumrowi
-       Then
-        norma := sumrowi;
-      t^[i] := 2*random-1;
-     h := abs(t^[i]);
-      If normr<h
-       Then
-        normr := h
-    End; {i}
-  k := 0;
-  while (k<n) and pd Do
-    Begin
-      kmin1 := k;
-     k := k+1;
-     k1n := (k-1)*n;
-     kk := k+k1n;
-     lkk := al^[kk];
-      For j:=1 To kmin1 Do
-        lkk := lkk-sqr(al^[j+k1n]);
-      If lkk<=0
-       Then
-        pd := false
-      Else
-        Begin
-          al^[kk] := sqrt(lkk);
-         lkk := al^[kk];
-          For i:=k+1 To n Do
-            Begin
-              i1n := (i-1)*n;
-             ik := k+i1n;
-             h := al^[ik];
-              For j:=1 To kmin1 Do
-                h := h-al^[j+k1n]*al^[j+i1n];
-              al^[ik] := h/lkk
-            End; {i}
-          h := t^[k];
-          For j:=1 To kmin1 Do
-            h := h-al^[j+k1n]*t^[j];
-          t^[k] := h/lkk;
-          h := px^[k];
-          For j:=1 To kmin1 Do
-            h := h-al^[j+k1n]*px^[j];
-          px^[k] := h/lkk
-        End {lkk > 0}
-    End; {k}
-    If pd
-     Then
-      Begin
-        normt := 0;
-        For i:=n Downto 1 Do
-          Begin
-            ii := i+(i-1)*n;
-           h := t^[i];
-            For j:=i+1 To n Do
-              h := h-al^[i+(j-1)*n]*t^[j];
-            t^[i] := h/al^[ii];
-            h := px^[i];
-            For j:=i+1 To n Do
-              h := h-al^[i+(j-1)*n]*px^[j];
-            px^[i] := h/al^[ii];
-            h := abs(t^[i]);
-            If normt<h
-              Then
-                normt := h
-          End; {i}
-        ca := norma*normt/normr
-      End; {pd}
-  If pd
-   Then
-    term := 1
-  Else
-    term := 2;
-  freemem(al, sqr(n)*sr);
- freemem(t, n*sr);
-End; {slegpd}
-
-Procedure slegpdl(n: ArbInt; Var a1; Var b1, x1, ca: ArbFloat;
-                  Var term: ArbInt);
-
-Var                   sr, i, j, k, kmin1 : ArbInt;
-                                      pd : boolean;
-    h, lkk, normr, normt, sumrowi, norma : ArbFloat;
-                                       a : ar2dr1 absolute a1;
-                                       b : arfloat1 absolute b1;
-                                       x : arfloat1 absolute x1;
-                                      al : par2dr1;
-                                       t : ^arfloat1;
-
-Begin
-  If n<1 Then
-    Begin
-      term := 3;
-     exit
-    End;
-  sr := sizeof(ArbFloat);
-  AllocateL2dr(n, al);
- getmem(t, n*sr);
-  For i:=1 To n Do
-   move(a[i]^, al^[i]^, i*sr);
-  move(b[1], x[1], n*sr);
-  normr := 0;
- pd := true ;
- norma := 0;
-  For i:=1 To n Do
-    Begin
-      sumrowi := 0;
-      For j:=1 To i Do
-       sumrowi := sumrowi+abs(al^[i]^[j]);
-      For j:=i+1 To n Do
-       sumrowi := sumrowi+abs(al^[j]^[i]);
-      If norma<sumrowi Then norma := sumrowi;
-      t^[i] := 2*random-1;
-     h := abs(t^[i]);
-      If normr<h Then normr := h
-    End; {i}
-  k := 0;
-  while (k<n) and pd Do
-    Begin
-      kmin1 := k;
-     k := k+1;
-     lkk := al^[k]^[k];
-      For j:=1 To kmin1 Do
-       lkk := lkk-sqr(al^[k]^[j]);
-      If lkk<=0 Then pd := false
-     Else
-        Begin
-          al^[k]^[k] := sqrt(lkk);
-         lkk := al^[k]^[k];
-          For i:=k+1 To n Do
-            Begin
-              h := al^[i]^[k];
-              For j:=1 To kmin1 Do
-               h := h-al^[k]^[j]*al^[i]^[j];
-              al^[i]^[k] := h/lkk
-            End; {i}
-          h := t^[k];
-          For j:=1 To kmin1 Do
-           h := h-al^[k]^[j]*t^[j];
-          t^[k] := h/lkk;
-         h := x[k];
-          For j:=1 To kmin1 Do
-           h := h-al^[k]^[j]*x[j];
-          x[k] := h/lkk
-        End {lkk > 0}
-    End; {k}
-    If pd Then
-      Begin
-        normt := 0;
-        For i:=n Downto 1 Do
-          Begin
-            h := t^[i];
-            For j:=i+1 To n Do
-             h := h-al^[j]^[i]*t^[j];
-            t^[i] := h/al^[i]^[i];
-            h := x[i];
-            For j:=i+1 To n Do
-             h := h-al^[j]^[i]*x[j];
-            x[i] := h/al^[i]^[i];
-           h := abs(t^[i]);
-            If normt<h Then normt := h
-          End; {i}
-        ca := norma*normt/normr
-      End; {pd}
-  If pd Then term := 1
- Else term := 2;
-  DeAllocateL2dr(n, al);
- freemem(t, n*sr);
-End; {slegpdl}
-
-Procedure slegsy(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
-                 Var term:ArbInt);
-
-Var 
-   i, j, kmin1, k, kplus1, kmin2, imin2, nsr, nsi, nsb, ii,
-   imin1, jmin1, indexpivot, iplus1, indi, indj, indk, indp       : ArbInt;
-   ra, h, absh, maxim, pivot, ct, norma, sumrowi, normt, normr, s : ArbFloat;
-              pa, pb, pb1, px, alt, l, d, t, u, v, l1, d1, u1, t1 : ^arfloat1;
-                                                                p : ^arint1;
-                                                                q : ^arbool1;
-Begin
-  If (n<1) Or (rwidth<1)
-   Then
-    Begin
-      term := 3;
-     exit
-    End; {if}
-  pa := @a;
- pb := @b;
- px := @x;
-  nsr := n*sizeof(ArbFloat);
-  nsi := n*sizeof(ArbInt);
-  nsb := n*sizeof(boolean);
-  getmem(alt, n*nsr);
-  getmem(l, nsr);
-  getmem(d, nsr);
-  getmem(t, nsr);
-  getmem(u, nsr);
-  getmem(v, nsr);
-  getmem(p, nsi);
-  getmem(q, nsb);
-  getmem(l1, nsr);
-  getmem(d1, nsr);
-  getmem(u1, nsr);
-  getmem(t1, nsr);
-  getmem(pb1, nsr);
-  move(pb^, pb1^, nsr);
-  For i:=1 To n Do
-    Begin
-      indi := (i-1)*n;
-      For j:=1 To i Do
-        alt^[indi+j] := pa^[(i-1)*rwidth+j];
-    End; {i}
-  norma := 0;
-  For i:=1 To n Do
-    Begin
-      indi := (i-1)*n;
-      p^[i] := i;
-     sumrowi := 0;
-      For j:=1 To i Do
-        sumrowi := sumrowi+abs(alt^[indi+j]);
-      For j:=i+1 To n Do
-        sumrowi := sumrowi+abs(alt^[(j-1)*n+i]);
-      If norma<sumrowi
-       Then
-        norma := sumrowi
-    End; {i}
-  kmin1 := -1;
- k := 0;
- kplus1 := 1;
-  while k<n Do
-    Begin
-      kmin2 := kmin1;
-     kmin1 := k;
-     k := kplus1;
-     kplus1 := kplus1+1;
-      indk := kmin1*n;
-      If k>3
-       Then
-        Begin
-          t^[2] := alt^[n+2]*alt^[indk+1]+alt^[2*n+2]*alt^[indk+2];
-          For i:=3 To kmin2 Do
-            Begin
-              indi := (i-1)*n;
-              t^[i] := alt^[indi+i-1]*alt^[indk+i-2]+alt^[indi+i]
-                       *alt^[indk+i-1]+alt^[indi+n+i]*alt^[indk+i]
-            End; {i}
-          t^[kmin1] := alt^[indk-n+kmin2]*alt^[indk+k-3]
-                       +alt^[indk-n+kmin1]*alt^[indk+kmin2]
-                       +alt^[indk+kmin1];
-          h := alt^[indk+k];
-          For j:=2 To kmin1 Do
-            h := h-t^[j]*alt^[indk+j-1];
-          t^[k] := h;
-          alt^[indk+k] := h-alt^[indk+kmin1]*alt^[indk+kmin2]
-        End {k>3}
-      Else
-       If k=3
-        Then
-        Begin
-          t^[2] := alt^[n+2]*alt^[2*n+1]+alt^[2*n+2];
-          h := alt^[2*n+3]-t^[2]*alt^[2*n+1];
-          t^[3] := h;
-          alt^[2*n+3] := h-alt^[2*n+2]*alt^[2*n+1]
-        End  {k=3}
-      Else
-       If k=2
-        Then
-        t^[2] := alt^[n+2];
-      maxim := 0;
-      For i:=kplus1 To n Do
-        Begin
-          indi := (i-1)*n;
-          h := alt^[indi+k];
-          For j:=2 To k Do
-            h := h-t^[j]*alt^[indi+j-1];
-          absh := abs(h);
-          If maxim<absh
-           Then
-            Begin
-              maxim := absh;
-             indexpivot := i
-            End; {if}
-          alt^[indi+k] := h
-        End; {i}
-      If maxim <> 0
-       Then
-        Begin
-          If indexpivot>kplus1
-           Then
-            Begin
-              indp := (indexpivot-1)*n;
-              indk := k*n;
-              p^[kplus1] := indexpivot;
-              For j:=1 To k Do
-                Begin
-                  h := alt^[indk+j];
-                  alt^[indk+j] := alt^[indp+j];
-                  alt^[indp+j] := h
-                End; {j}
-              For j:=indexpivot Downto kplus1 Do
-                Begin
-                  indj := (j-1)*n;
-                  h := alt^[indj+kplus1];
-                  alt^[indj+kplus1] := alt^[indp+j];
-                  alt^[indp+j] := h
-                End; {j}
-              For i:=indexpivot To n Do
-                Begin
-                  indi := (i-1)*n;
-                  h := alt^[indi+kplus1];
-                  alt^[indi+kplus1] := alt^[indi+indexpivot];
-                  alt^[indi+indexpivot] := h
-                End  {i}
-            End; {if}
-          pivot := alt^[k*n+k];
-          For i:=k+2 To n Do
-            alt^[(i-1)*n+k] := alt^[(i-1)*n+k]/pivot
-        End {maxim <> 0}
-    End; {k}
-  d^[1] := alt^[1];
- i := 1;
-  while i<n Do
-    Begin
-      imin1 := i;
-     i := i+1;
-      u^[imin1] := alt^[(i-1)*n+imin1];
-      l^[imin1] := u^[imin1];
-     d^[i] := alt^[(i-1)*n+i]
-    End; {i}
-  mdtgtr(n, l^[1], d^[1], u^[1], l1^[1], d1^[1], u1^[1], v^[1],
-         q^[1], ct, term);
-  If term=1
-   Then
-    Begin
-      normr := 0;
-      For i:=1 To n Do
-        Begin
-          t^[i] := 2*random-1;
-         h := t^[i];
-          h := abs(h);
-          If normr<h
-           Then
-            normr := h
-        End; {i}
-      For i:=1 To n Do
-        Begin
-          indexpivot := p^[i];
-          If indexpivot <> i
-           Then
-            Begin
-              h := pb1^[i];
-             pb1^[i] := pb1^[indexpivot];
-              pb1^[indexpivot] := h
-            End {if}
-        End; {i}
-      i := 0;
-      while i<n Do
-        Begin
-          indi := i*n;
-          imin1 := i;
-         i := i+1;
-         j := 1;
-         h := t^[i];
-         s := pb1^[i];
-          while j<imin1 Do
-            Begin
-              jmin1 := j;
-             j := j+1;
-              s := s-alt^[indi+jmin1]*pb1^[j];
-              h := h-alt^[indi+jmin1]*t^[j]
-            End; {j}
-          t^[i] := h;
-         pb1^[i] := s
-        End; {i}
-      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], pb1^[1], px^[1], term);
-      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], t^[1], t1^[1], term);
-      i := n+1;
-     imin1 := n;
-     normt := 0;
-      while i>2 Do
-        Begin
-          iplus1 := i;
-         i := imin1;
-         imin1 := imin1-1;
-          h := t1^[i];
-         s := px^[i];
-          For j:=iplus1 To n Do
-            Begin
-              indj := (j-1)*n+imin1;
-              h := h-alt^[indj]*t1^[j];
-              s := s-alt^[indj]*px^[j]
-            End; {j}
-          px^[i] := s;
-          t1^[i] := h;
-         h := abs(h);
-          If normt<h
-           Then
-            normt := h
-        End; {i}
-      For i:=n Downto 1 Do
-        Begin
-          indexpivot := p^[i];
-          If indexpivot <> i
-           Then
-            Begin
-              h := px^[i];
-             px^[i] := px^[indexpivot];
-              px^[indexpivot] := h
-            End {if}
-        End; {i}
-      ca := norma*normt/normr
-    End {term=1}
-  Else
-    term := 2;
-  freemem(alt, n*nsr);
-  freemem(l, nsr);
-  freemem(d, nsr);
-  freemem(t, nsr);
-  freemem(u, nsr);
-  freemem(v, nsr);
-  freemem(p, nsi);
-  freemem(q, nsb);
-  freemem(l1, nsr);
-  freemem(d1, nsr);
-  freemem(u1, nsr);
-  freemem(t1, nsr);
-  freemem(pb1, nsr);
-End; {slegsy}
-
-Procedure slegsyl(n: ArbInt; Var a1; Var b1, x1, ca: ArbFloat;
-                  Var term: ArbInt);
-
-Var 
-   i, j, kmin1, k, kplus1, kmin2, imin2, nsr, nsi, nsb, ii,
-   imin1, jmin1, indexpivot, iplus1, indi, indj, indk, indp       : ArbInt;
-   ra, h, absh, maxim, pivot, ct, norma, sumrowi, normt, normr, s : ArbFloat;
-                                           a : ar2dr1 absolute a1;
-                                           b : arfloat1 absolute b1;
-                                           x : arfloat1 absolute x1;
-           b0, l, d, t, u, v, l1, d1, u1, t1 : ^arfloat1;
-                                         alt : par2dr1;
-                                           p : ^arint1;
-                                           q : ^arbool1;
-Begin
-  If n<1 Then
-    Begin
-      term := 3;
-     exit
-    End; {if}
-  nsr := n*sizeof(ArbFloat);
- nsi := n*sizeof(ArbInt);
- nsb := n*sizeof(boolean);
-  AllocateL2dr(n, alt);
-  getmem(l, nsr);
- getmem(d, nsr);
- getmem(t, nsr);
-  getmem(u, nsr);
- getmem(v, nsr);
- getmem(p, nsi);
-  getmem(q, nsb);
- getmem(l1, nsr);
- getmem(d1, nsr);
-  getmem(u1, nsr);
- getmem(t1, nsr);
- getmem(b0, nsr);
-  move(b[1], b0^, nsr);
-  For i:=1 To n Do
-   move(a[i]^, alt^[i]^, i*sizeof(ArbFloat));
-  norma := 0;
-  For i:=1 To n Do
-    Begin
-      p^[i] := i;
-     sumrowi := 0;
-      For j:=1 To i Do
-       sumrowi := sumrowi+abs(alt^[i]^[j]);
-      For j:=i+1 To n Do
-       sumrowi := sumrowi+abs(alt^[j]^[i]);
-      If norma<sumrowi Then norma := sumrowi
-    End; {i}
-  k := 0;
-  while k<n Do
-    Begin
-      Inc(k);
-      If k>3 Then
-        Begin
-          t^[2] := alt^[2]^[2]*alt^[k]^[1]+alt^[3]^[2]*alt^[k]^[2];
-          For i:=3 To k-2 Do
-            t^[i] := alt^[i]^[i-1]*alt^[k]^[i-2]+alt^[i]^[i]
-                     *alt^[k]^[i-1]+alt^[i+1]^[i]*alt^[k]^[i];
-          t^[k-1] := alt^[k-1]^[k-2]*alt^[k]^[k-3]
-                     +alt^[k-1]^[k-1]*alt^[k]^[k-2]+alt^[k]^[k-1];
-          h := alt^[k]^[k];
-          For j:=2 To k-1 Do
-           h := h-t^[j]*alt^[k]^[j-1];
-          t^[k] := h;
-          alt^[k]^[k] := h-alt^[k]^[k-1]*alt^[k]^[k-2]
-        End {k>3}
-      Else
-       If k=3
-        Then
-        Begin
-          t^[2] := alt^[2]^[2]*alt^[3]^[1]+alt^[3]^[2];
-          h := alt^[3]^[3]-t^[2]*alt^[3]^[1];
-          t^[3] := h;
-          alt^[3]^[3] := h-alt^[3]^[2]*alt^[3]^[1]
-        End  {k=3}
-      Else
-       If k=2 Then t^[2] := alt^[2]^[2];
-      maxim := 0;
-      For i:=k+1 To n Do
-        Begin
-          h := alt^[i]^[k];
-          For j:=2 To k Do
-           h := h-t^[j]*alt^[i]^[j-1];
-          absh := abs(h);
-          If maxim<absh Then
-            Begin
-              maxim := absh;
-             indexpivot := i
-            End; {if}
-          alt^[i]^[k] := h
-        End; {i}
-      If maxim <> 0
-       Then
-        Begin
-          If indexpivot>k+1 Then
-            Begin
-              p^[k+1] := indexpivot;
-              For j:=1 To k Do
-                Begin
-                  h := alt^[k+1]^[j];
-                  alt^[k+1]^[j] := alt^[indexpivot]^[j];
-                  alt^[indexpivot]^[j] := h
-                End; {j}
-              For j:=indexpivot Downto k+1 Do
-                Begin
-                  h := alt^[j]^[k+1];
-                  alt^[j]^[k+1] := alt^[indexpivot]^[j];
-                  alt^[indexpivot]^[j] := h
-                End; {j}
-              For i:=indexpivot To n Do
-                Begin
-                  h := alt^[i]^[k+1];
-                  alt^[i]^[k+1] := alt^[i]^[indexpivot];
-                  alt^[i]^[indexpivot] := h
-                End  {i}
-            End; {if}
-          pivot := alt^[k+1]^[k];
-          For i:=k+2 To n Do
-           alt^[i]^[k] := alt^[i]^[k]/pivot
-        End {maxim <> 0}
-    End; {k}
-  d^[1] := alt^[1]^[1];
- i := 1;
-  while i<n Do
-    Begin
-      Inc(i);
-      u^[i-1] := alt^[i]^[i-1];
-      l^[i-1] := u^[i-1];
-     d^[i] := alt^[i]^[i]
-    End; {i}
-  mdtgtr(n, l^[1], d^[1], u^[1], l1^[1], d1^[1], u1^[1], v^[1],
-         q^[1], ct, term);
-  If term=1 Then
-    Begin
-      normr := 0;
-      For i:=1 To n Do
-        Begin
-          t^[i] := 2*random-1;
-         h := t^[i];
-          h := abs(h);
-          If normr<h Then normr := h
-        End; {i}
-      For i:=1 To n Do
-        Begin
-          indexpivot := p^[i];
-          If indexpivot <> i
-           Then
-            Begin
-              h := b0^[i];
-             b0^[i] := b0^[indexpivot];
-              b0^[indexpivot] := h
-            End {if}
-        End; {i}
-      i := 0;
-      while i<n Do
-        Begin
-          Inc(i);
-         j := 1;
-         h := t^[i];
-         s := b0^[i];
-          while j<i-1 Do
-            Begin
-              Inc(j);
-              s := s-alt^[i]^[j-1]*b0^[j];
-              h := h-alt^[i]^[j-1]*t^[j]
-            End; {j}
-          t^[i] := h;
-         b0^[i] := s
-        End; {i}
-      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], b0^[1], x[1], term);
-      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], t^[1], t1^[1], term);
-      i := n+1;
-     normt := 0;
-      while i>2 Do
-        Begin
-          Dec(i);
-          h := t1^[i];
-         s := x[i];
-          For j:=i+1 To n Do
-            Begin
-              h := h-alt^[j]^[i-1]*t1^[j];
-              s := s-alt^[j]^[i-1]*x[j]
-            End; {j}
-          x[i] := s;
-         t1^[i] := h;
-         h := abs(h);
-          If normt<h Then normt := h
-        End; {i}
-      For i:=n Downto 1 Do
-        Begin
-          indexpivot := p^[i];
-          If indexpivot <> i Then
-            Begin
-              h := x[i];
-             x[i] := x[indexpivot];
-             x[indexpivot] := h
-            End {if}
-        End; {i}
-      ca := norma*normt/normr
-    End {term=1}
-  Else
-    term := 2;
-  freemem(l, nsr);
- freemem(d, nsr);
- freemem(t, nsr);
-  freemem(u, nsr);
- freemem(v, nsr);
- freemem(p, nsi);
-  freemem(q, nsb);
- freemem(l1, nsr);
- freemem(d1, nsr);
-  freemem(u1, nsr);
- freemem(t1, nsr);
- freemem(b0, nsr);
-  DeAllocateL2dr(n, alt);
-End; {slegsyl}
-
-Procedure slegtr(n:ArbInt; Var l, d, u, b, x, ca: ArbFloat;
-                 Var term: ArbInt);
-
-Var                           singular, ch : boolean;
-               i, j, nm1, sr, n1s, ns, n2s : ArbInt;
-            normr, normt, h, lj, di, ui, m : ArbFloat;
-                                    pl, ll : ^arfloat2;
-    pd, pu, pb, px, dd, uu1, u2, t, sumrow : ^arfloat1;
-Begin
-  If n<1
-   Then
-    Begin
-      term := 3;
-     exit
-    End; {n<1}
-  sr := sizeof(ArbFloat);
- n1s := (n-1)*sr;
- ns := n1s+sr;
- n2s := n1s;
-  getmem(ll, n1s);
-  getmem(uu1, n1s);
-  getmem(u2, n2s);
-  getmem(dd, ns);
-  getmem(t, ns);
-  getmem(sumrow, ns);
-
-  pl := @l;
- pd := @d;
- pu := @u;
- pb := @b;
- px := @x;
-  move(pl^[2], ll^[2], n1s);
-  move(pd^[1], dd^[1], ns);
-  If n>1
-   Then
-    move(pu^[1], uu1^[1], n1s);
-  move(pb^[1], px^[1], ns);
-  normr := 0;
- singular := false;
-  nm1 := n-1;
- i := 0;
-  while (i<n) and not singular Do
-    Begin
-      i := i+1;
-      If i=1
-       Then
-        Begin
-          sumrow^[i] := abs(dd^[1]);
-          If n>1
-           Then
-            sumrow^[i] := sumrow^[i]+abs(uu1^[1])
-        End {i=1}
-      Else
-        If i=n
-         Then
-          sumrow^[i] := abs(ll^[n])+abs(dd^[n])
-        Else
-          sumrow^[i] := abs(ll^[i])+abs(dd^[i])+abs(uu1^[i]);
-      If sumrow^[i]=0
-       Then
-        singular := true
-      Else
-        Begin
-          h := 2*random-1;
-         t^[i] := sumrow^[i]*h;
-          h := abs(h);
-          If normr<h
-           Then
-            normr := h
-        End {sumrow^[i] <> 0}
-    End; {i}
-  j := 1;
-  while (j <> n) and  not singular Do
-    Begin
-      i := j;
-     j := j+1;
-     lj := ll^[j];
-      If lj <> 0
-       Then
-        Begin
-          di := dd^[i];
-          ch := abs(di/sumrow^[i])<abs(lj/sumrow^[j]);
-          If ch
-           Then
-            Begin
-              ui := uu1^[i];
-             dd^[i] := lj;
-             uu1^[i] := dd^[j];
-             m := di/lj;
-              dd^[j] := ui-m*dd^[j];
-              If i<nm1
-               Then
-                Begin
-                  u2^[i] := uu1^[j];
-                 uu1^[j] := -m*u2^[i]
-                End; {i<nm1}
-              sumrow^[j] := sumrow^[i];
-              h := t^[i];
-             t^[i] := t^[j];
-             t^[j] := h-m*t^[i];
-             h := px^[i];
-              px^[i] := px^[j];
-             px^[j] := h-m*px^[i]
-            End {ch}
-          Else
-            Begin
-              m := lj/di;
-             dd^[j] := dd^[j]-m*uu1^[i];
-              If i<nm1
-               Then
-                u2^[i] := 0;
-              t^[j] := t^[j]-m*t^[i];
-             px^[j] := px^[j]-m*px^[i]
-            End {not ch}
-        End {lj <> 0}
-      Else
-        Begin
-          If i < nm1
-            Then
-              u2^[i] := 0;
-          If dd^[i]=0
-           Then
-            singular := true
-        End {lj=0}
-    End; {j}
-  If dd^[n]=0
-   Then
-    singular := true;
-  If  Not singular
-    Then
-      Begin
-        normt := 0;
-       t^[n] := t^[n]/dd^[n];
-       px^[n] := px^[n]/dd^[n];
-       h := abs(t^[n]);
-        If normt<h
-         Then
-          normt := h;
-        If n>1
-         Then
-          Begin
-            t^[nm1] := (t^[nm1]-uu1^[nm1]*t^[n])/dd^[nm1];
-            px^[nm1] := (px^[nm1]-uu1^[nm1]*px^[n])/dd^[nm1];
-           h := abs(t^[nm1])
-          End; {n>1}
-        If normt<h
-         Then
-          normt := h;
-        For i:=n-2 Downto 1 Do
-          Begin
-            t^[i] := (t^[i]-uu1^[i]*t^[i+1]-u2^[i]*t^[i+2])/dd^[i];
-            px^[i] := (px^[i]-uu1^[i]*px^[i+1]-u2^[i]*px^[i+2])/dd^[i];
-            h := abs(t^[i]);
-            If normt<h
-             Then
-              normt := h
-          End; {i}
-        ca := normt/normr
-      End; {not singular}
-  If singular
-   Then
-    term := 2
-  Else
-    term := 1;
-  freemem(ll, n1s);
-  freemem(uu1, n1s);
-  freemem(u2, n2s);
-  freemem(dd, ns);
-  freemem(t, ns);
-  freemem(sumrow, ns);
-End; {slegtr}
-
-Begin
-  randseed := 12345
-End.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:45  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:15  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/spe.pas

@@ -1,1316 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Special functions. (Currently, most of these functions only work for
-            ArbFloat=REAL/DOUBLE, not for Extended(at least not at full
-            precision, implement the tables in the diverse functions
-            for extended)
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-unit spe;
-{$I DIRECT.INC}
-
-interface
-
-uses typ;
-
-{  Calculate modified Besselfunction "of the first kind" I0(x) }
-function spebi0(x: ArbFloat): ArbFloat;
-
-{  Calculate modified Besselfunction "of the first kind" I1(x) }
-function spebi1(x: ArbFloat): ArbFloat;
-
-{  Calculate Besselfunction "of the first kind" J0(x) }
-function spebj0(x: ArbFloat): ArbFloat;
-
-{  Calculate Besselfunction "of the first kind" J1(x) }
-function spebj1(x: ArbFloat): ArbFloat;
-
-{  Calculate modified Besselfunction "of the second kind" K0(x) }
-function spebk0(x: ArbFloat): ArbFloat;
-
-{  Calculate modified Besselfunction "of the second kind" K1(x) }
-function spebk1(x: ArbFloat): ArbFloat;
-
-{  Calculate Besselfunction "of the second kind" Y0(x) }
-function speby0(x: ArbFloat): ArbFloat;
-
-{  Calculate Besselfunction "of the second kind" Y1(x) }
-function speby1(x: ArbFloat): ArbFloat;
-
-{  Entier function, calculates first integer greater or equal than X}
-function speent(x: ArbFloat): longint;
-
-{  Errorfunction ( 2/sqrt(pi)* Int(t,0,pi,exp(sqr(t)) )}
-function speerf(x: ArbFloat): ArbFloat;
-
-{  Errorfunction's complement ( 2/sqrt(pi)* Int(t,pi,inf,exp(sqr(t)) )}
-function speefc(x: ArbFloat): ArbFloat;
-
-{  Function to calculate the Gamma function ( int(t,0,inf,t^(x-1)*exp(-t)) }
-function spegam(x: ArbFloat): ArbFloat;
-
-{  Function to calculate the natural logaritm of the Gamma function}
-function spelga(x: ArbFloat): ArbFloat;
-
-{  "Calculates" the maximum of two ArbFloat values     }
-function spemax(a, b: ArbFloat): ArbFloat;
-
-{  Calculates the functionvalue of a polynomalfunction with n coefficients in a
-for variable X }
-function spepol(x: ArbFloat; var a: ArbFloat; n: ArbInt): ArbFloat;
-
-{ Calc a^b with a and b real numbers}
-function spepow(a, b: ArbFloat): ArbFloat;
-
-{ Returns sign of x (-1 for x<0, 0 for x=0 and 1 for x>0)  }
-function spesgn(x: ArbFloat): ArbInt;
-
-{  ArcSin(x) }
-function spears(x: ArbFloat): ArbFloat;
-
-{  ArcCos(x) }
-function spearc(x: ArbFloat): ArbFloat;
-
-{  Sinh(x) }
-function spesih(x: ArbFloat): ArbFloat;
-
-{  Cosh(x) }
-function specoh(x: ArbFloat): ArbFloat;
-
-{  Tanh(x) }
-function spetah(x: ArbFloat): ArbFloat;
-
-{  ArcSinH(x) }
-function speash(x: ArbFloat): ArbFloat;
-
-{  ArcCosh(x) }
-function speach(x: ArbFloat): ArbFloat;
-
-{  ArcTanH(x) }
-function speath(x: ArbFloat): ArbFloat;
-
-implementation
-
-function spebi0(x: ArbFloat): ArbFloat;
-
-const
-
-     xvsmall = 3.2e-9;
-          a1 : array[0..23] of ArbFloat =
-               (  3.08508322553671039e-1, -1.86478066609466760e-1,
-                  1.57686843969995904e-1, -1.28895621330524993e-1,
-                  9.41616340200868389e-2, -6.04316795007737183e-2,
-                  3.41505388391452157e-2, -1.71317947935716536e-2,
-                  7.70061052263382555e-3, -3.12923286656374358e-3,
-                  1.15888319775791686e-3, -3.93934532072526720e-4,
-                  1.23682594989692688e-4, -3.60645571444886286e-5,
-                  9.81395862769787105e-6, -2.50298975966588680e-6,
-                  6.00566861079330132e-7, -1.36042013507151017e-7,
-                  2.92096163521178835e-8, -5.94856273204259507e-9,
-                  1.13415934215369209e-9, -2.10071360134551962e-10,
-                  4.44484446637868974e-11,-7.48150165756234957e-12);
-          a2 : array[0..26] of ArbFloat =
-               (  1.43431781856850311e-1, -3.71571542566085323e-2,
-                  1.44861237337359455e-2, -6.30121694459896307e-3,
-                  2.89362046530968701e-3, -1.37638906941232170e-3,
-                  6.72508592273773611e-4, -3.35833513200679384e-4,
-                  1.70524543267970595e-4, -8.74354291104467762e-5,
-                  4.48739019580173804e-5, -2.28278155280668483e-5,
-                  1.14032404021741277e-5, -5.54917762110482949e-6,
-                  2.61457634142262604e-6, -1.18752840689765504e-6,
-                  5.18632519069546106e-7, -2.17653548816447667e-7,
-                  8.75291839187305722e-8, -3.34900221934314738e-8,
-                  1.24131668344616429e-8, -4.66215489983794905e-9,
-                  1.58599776268172290e-9, -3.80370174256271589e-10,
-                  1.23188158175419302e-10,-8.46900307934754898e-11,
-                  2.45185252963941089e-11);
-           a3: array[0..19] of ArbFloat =
-               (  4.01071065066847416e-1,  2.18216817211694382e-3,
-                  5.59848253337377763e-5,  2.79770701849785597e-6,
-                  2.17160501061222148e-7,  2.36884434055843528e-8,
-                  3.44345025431425567e-9,  6.47994117793472057e-10,
-                  1.56147127476528831e-10, 4.82726630988879388e-11,
-                  1.89599322920800794e-11, 1.05863621425699789e-11,
-                  8.27719401266046976e-12, 2.82807056475555021e-12,
-                 -4.34624739357691085e-12,-4.29417106720584499e-12,
-                  4.30812577328136192e-13, 1.44572313799118029e-12,
-                  4.73229306831831040e-14,-1.95679809047625728e-13);
-
-
-var t : ArbFloat;
-
-begin
-  t:=abs(x);
-  if t <=xvsmall
-  then
-    spebi0:=1
-  else
-  if t <= 4
-  then
-    spebi0 := exp(t)*spepol(t/2-1, a1[0], SizeOf(a1) div SizeOf(ArbFloat) -1)
-  else
-  if t <= 12
-  then
-    spebi0:=exp(t)*spepol(t/4-2, a2[0], SizeOf(a2) div SizeOf(ArbFloat) -1)
-  else { t > 12}
-    spebi0:=(exp(t)/sqrt(t))*
-            spepol(24/t-1, a3[0], SizeOf(a3) div SizeOf(ArbFloat) -1)
-end; {spebi0}
-
-function spebi1(x: ArbFloat): ArbFloat;
-
-
-const xvsmall = 3.2e-9;
-      a1: array[0..11] of ArbFloat =
-      ( 1.19741654963670236e+0, 9.28758890114609554e-1,
-        2.68657659522092832e-1, 4.09286371827770484e-2,
-        3.84763940423809498e-3, 2.45224314039278904e-4,
-        1.12849795779951847e-5, 3.92368710996392755e-7,
-        1.06662712314503955e-8, 2.32856921884663846e-10,
-        4.17372709788222413e-12,6.24387910353848320e-14);
-
-      a2: array[0..26] of ArbFloat =
-      ( 1.34142493292698178e-1, -2.99140923897405570e-2,
-        9.76021102528646704e-3, -3.40759647928956354e-3,
-        1.17313412855965374e-3, -3.67626180992174570e-4,
-        8.47999438119288094e-5,  5.21557319070236939e-6,
-       -2.62051678511418163e-5,  2.47493270133518925e-5,
-       -1.79026222757948636e-5,  1.13818992442463952e-5,
-       -6.63144162982509821e-6,  3.60186151617732531e-6,
-       -1.83910206626348772e-6,  8.86951515545183908e-7,
-       -4.05456611578551130e-7,  1.76305222240064495e-7,
-       -7.28978293484163628e-8,  2.84961041291017650e-8,
-       -1.07563514207617768e-8,  4.11321223904934809e-9,
-       -1.41575617446629553e-9,  3.38883570696523350e-10,
-       -1.10970391104678003e-10, 7.79929176497056645e-11,
-       -2.27061376122617856e-11);
-
-       a3: array[0..19] of ArbFloat =
-       ( 3.92624494204116555e-1, -6.40545360348237412e-3,
-        -9.12475535508497109e-5, -3.82795135453556215e-6,
-        -2.72684545741400871e-7, -2.82537120880041703e-8,
-        -3.96757162863209348e-9, -7.28107961041827952e-10,
-        -1.72060490748583241e-10,-5.23524129533553498e-11,
-        -2.02947854602758139e-11,-1.11795516742222899e-11,
-        -8.69631766630563635e-12,-3.05957293450420224e-12,
-         4.42966462319664333e-12, 4.47735589657057690e-12,
-        -3.95353303949377536e-13,-1.48765082315961139e-12,
-        -5.77176811730370560e-14, 1.99448557598015488e-13);
-
-var t : ArbFloat;
-
-begin
-  t:=abs(x);
-  if t <= xvsmall
-  then
-    spebi1:=x/2
-  else
-  if t <= 4
-  then
-    spebi1:=x*spepol(sqr(t)/8-1, a1[0], sizeof(a1) div sizeof(ArbFloat)-1)
-  else
-  if t <= 12
-  then
-    spebi1:=
-      exp(t)*spepol(t/4-2, a2[0], sizeof(a2) div sizeof(ArbFloat)-1)*spesgn(x)
-  else { t > 12}
-    spebi1:=
-      (exp(t)/sqrt(t))*
-      spepol(24/t-1, a3[0], sizeof(a3) div sizeof(ArbFloat)-1)*spesgn(x)
-end; {spebi1}
-
-function spebj0(x: ArbFloat): ArbFloat;
-const
-
-       xvsmall = 3.2e-9;
-          tbpi = 6.36619772367581343e-1;
-           a1 : array[0..5] of ArbFloat =
-           ( 1.22200000000000000e-17, -1.94383469000000000e-12,
-             7.60816359241900000e-8,  -4.60626166206275050e-4,
-             1.58067102332097261e-1,  -8.72344235285222129e-3);
-
-            b1 : array[0..5] of ArbFloat =
-            ( - 7.58850000000000000e-16, 7.84869631400000000e-11,
-              - 1.76194690776215000e-6,  4.81918006946760450e-3,
-              - 3.70094993872649779e-1,  1.57727971474890120e-1);
-
-            c1 : array[0..4] of ArbFloat =
-            ( 4.12532100000000000e-14, - 2.67925353056000000e-9,
-              3.24603288210050800e-5,  - 3.48937694114088852e-2,
-              2.65178613203336810e-1);
-
-            d1 : array[0..13] of ArbFloat =
-            ( 9.99457275788251954e-1, -5.36367319213004570e-4,
-              6.13741608010926000e-6, -2.05274481565160000e-7,
-              1.28037614434400000e-8, -1.21211819632000000e-9,
-              1.55005642880000000e-10,-2.48827276800000000e-11,
-              4.78702080000000000e-12,-1.06365696000000000e-12,
-              2.45294080000000000e-13,-6.41843200000000000e-14,
-              3.34028800000000000e-14,-1.17964800000000000e-14);
-
-             d2 : array[0..16] of ArbFloat =
-             ( -1.55551138795135187e-2,  6.83314909934390000e-5,
-               -1.47713883264594000e-6,  7.10621485930000000e-8,
-               -5.66871613024000000e-9,  6.43278173280000000e-10,
-               -9.47034774400000000e-11, 1.70330918400000000e-11,
-               -3.59094272000000000e-12, 8.59855360000000000e-13,
-               -2.28807680000000000e-13, 6.95193600000000000e-14,
-               -2.27942400000000000e-14, 4.75136000000000000e-15,
-               -1.14688000000000000e-15, 2.12992000000000000e-15,
-               -9.83040000000000000e-16);
-
-var t, g, y, t2, a, b, c, cx, sx : ArbFloat;
-    i, bov                       : ArbInt;
-
-begin
-  t:=abs(x);
-  if t<=xvsmall
-  then
-    spebj0:=1
-  else
-  if t<=8
-  then
-    begin
-      t:=0.03125*sqr(t)-1; t2:=2*t;
-      b:=0; c:=0;
-      bov:=sizeof(a1) div sizeof(ArbFloat) - 1;
-      for i:=0 to bov do
-        begin
-          a:=t2*c-b+a1[i];
-          if i<5
-          then
-            b:=t2*a-c+b1[i]
-          else
-            spebj0:=t*a-c+b1[i];
-          if i<bov
-          then
-            c:=t2*b-a+c1[i]
-          else
-            if i<5
-            then
-              spebj0:=t*b-a+c1[i]
-        end {i}
-    end {abs(x)<=8}
-  else
-    begin
-      g:=t-1/(2*tbpi); y:=sqrt(tbpi/t);
-      cx:=cos(g)*y; sx:=-sin(g)*y*8/t;
-      t:=128/sqr(t)-1;
-      spebj0:=cx*spepol(t, d1[0], sizeof(d1) div sizeof(ArbFloat) - 1)
-              + sx*spepol(t, d2[0], sizeof(d2) div sizeof(ArbFloat) - 1)
-    end {abs(x)>8}
-    
-end {spebj0};
-
-function spebj1(x: ArbFloat): ArbFloat;
-const
-
-       xvsmall = 3.2e-9;
-          tbpi = 6.36619772367581343e-1;
-      a1 : array[0..5] of ArbFloat =
-      ( 2.95000000000000000e-18, -5.77740420000000000e-13,
-        2.94970700727800000e-8,  -2.60444389348580680e-4,
-        1.77709117239728283e-1,  -1.19180116054121687e+0);
-
-      b1 : array[0..5] of ArbFloat =
-      ( -1.95540000000000000e-16, 2.52812366400000000e-11,
-        -7.61758780540030000e-7,  3.24027018268385747e-3,
-        -6.61443934134543253e-1,  6.48358770605264921e-1);
-
-      c1 : array[0..4] of ArbFloat =
-      ( 1.13857200000000000e-14, -9.42421298160000000e-10,
-        1.58870192399321300e-5,  -2.91755248061542077e-2,
-        1.28799409885767762e+0);
-
-       d1 : array[0..13] of ArbFloat =
-       ( 1.00090702627808217e+0,  8.98804941670557880e-4,
-        -7.95969469843846000e-6,  2.45367662227560000e-7,
-        -1.47085129889600000e-8,  1.36030580128000000e-9,
-        -1.71310758400000000e-10, 2.72040729600000000e-11,
-        -5.19113984000000000e-12, 1.14622464000000000e-12,
-        -2.63372800000000000e-13, 6.86387200000000000e-14,
-        -3.54508800000000000e-14, 1.24928000000000000e-14);
-
-       d2 : array[0..15] of ArbFloat =
-       ( 4.67768740274489776e-2,  -9.62145882205441600e-5,
-         1.82120185123076000e-6,  -8.29196070929200000e-8,
-         6.42013250344000000e-9,  -7.15110504800000000e-10,
-         1.03950931840000000e-10, -1.85248000000000000e-11,
-         3.87554432000000000e-12, -9.23228160000000000e-13,
-         2.50224640000000000e-13, -7.43936000000000000e-14,
-         1.75718400000000000e-14, -4.83328000000000000e-15,
-         5.32480000000000000e-15, -2.29376000000000000e-15);
-
-var t, g, y, t2, a, b, c, cx, sx : ArbFloat;
-    i, bov                       : ArbInt;
-
-begin
-  t:=abs(x);
-  if t<xvsmall
-  then
-    spebj1:=x/2
-  else
-  if t<=8
-  then
-    begin
-      t:=0.03125*sqr(t)-1; t2:=2*t;
-      b:=0; c:=0;
-      bov:=sizeof(a1) div sizeof(ArbFloat) - 1;
-      for i:=0 to bov do
-        begin
-          a:=t2*c-b+a1[i];
-          if i<bov
-          then
-            begin
-              b:=t2*a-c+b1[i];
-              c:=t2*b-a+c1[i]
-            end
-          else
-            spebj1:=(x/8)*(t*a-c+b1[i])
-        end {i}
-    end {abs(x)<=8}
-  else
-    begin
-      g:=t-1.5/tbpi; y:=sqrt(tbpi/t)*spesgn(x);
-      cx:=cos(g)*y; sx:=-sin(g)*y*8/t;
-      t:=128/sqr(t)-1;
-      spebj1:=cx*spepol(t, d1[0], sizeof(d1) div sizeof(ArbFloat) - 1)
-              + sx*spepol(t, d2[0], sizeof(d2) div sizeof(ArbFloat) - 1)
-    end {abs(x)>8}
-end {spebj1};
-
-function spebk0(x: ArbFloat): ArbFloat;
-
-const
-
-     egam = 0.57721566490153286;
-     xvsmall = 3.2e-9;
-     highexp = 745;
-
-      a0: array[0..7] of ArbFloat =
-      ( 1.12896092945412762e+0,  1.32976966478338191e-1,
-        4.07157485171389048e-3,  5.59702338227915383e-5,
-        4.34562671546158210e-7,  2.16382411824721532e-9,
-        7.49110736894134794e-12, 1.90674197514561280e-14);
-
-      a1: array[0..8] of ArbFloat =
-      ( 2.61841879258687055e-1,  1.52436921799395196e-1,
-        6.63513979313943827e-3,  1.09534292632401542e-4,
-        9.57878493265929443e-7,  5.19906865800665633e-9,
-        1.92405264219706684e-11, 5.16867886946332160e-14,
-        1.05407718191360000e-16);
-
-      a2: array[0..22] of ArbFloat =
-      ( 9.58210053294896496e-1, -1.42477910128828254e-1,
-        3.23582010649653009e-2, -8.27780350351692662e-3,
-        2.24709729617770471e-3, -6.32678357460594866e-4,
-        1.82652460089342789e-4, -5.37101208898441760e-5,
-        1.60185974149720562e-5, -4.83134250336922161e-6,
-        1.47055796078231691e-6, -4.51017292375200017e-7,
-        1.39217270224614153e-7, -4.32185089841834127e-8,
-        1.34790467361340101e-8, -4.20597329258249948e-9,
-        1.32069362385968867e-9, -4.33326665618780914e-10,
-        1.37999268074442719e-10, -3.19241059198852137e-11,
-        9.74410152270679245e-12, -7.83738609108569293e-12,
-        2.57466288575820595e-12);
-
-      a3: array[0..22] of ArbFloat =
-     ( 6.97761598043851776e-1, -1.08801882084935132e-1,
-       2.56253646031960321e-2, -6.74459607940169198e-3,
-       1.87292939725962385e-3, -5.37145622971910027e-4,
-       1.57451516235860573e-4, -4.68936653814896712e-5,
-       1.41376509343622727e-5, -4.30373871727268511e-6,
-       1.32052261058932425e-6, -4.07851207862189007e-7,
-       1.26672629417567360e-7, -3.95403255713518420e-8,
-       1.23923137898346852e-8, -3.88349705250555658e-9,
-       1.22424982779432970e-9, -4.03424607871960089e-10,
-       1.28905587479980147e-10,-2.97787564633235128e-11,
-       9.11109430833001267e-12,-7.39672783987933184e-12,
-       2.43538242247537459e-12);
-      a4: array[0..16] of ArbFloat =
-      ( 1.23688664769425422e+0,  -1.72683652385321641e-2,
-       -9.25551464765637133e-4,  -9.02553345187404564e-5,
-       -6.31692398333746470e-6,  -7.69177622529272933e-7,
-       -4.16044811174114579e-8,  -9.41555321137176073e-9,
-        1.75359321273580603e-10, -2.22829582288833265e-10,
-        3.49564293256545992e-11, -1.11391758572647639e-11,
-        2.85481235167705907e-12, -7.31344482663931904e-13,
-        2.06328892562554880e-13, -1.28108310826991616e-13,
-        4.43741979886551040e-14);
-
-
-var t: ArbFloat;
-
-begin
-  if x<=0
-  then
-    RunError(401);
-  if x<=xvsmall
-  then
-    spebk0:=-(ln(x/2)+egam)
-  else
-  if x<=1
-  then
-    begin
-      t:=2*sqr(x)-1;
-      spebk0:=-ln(x)*spepol(t, a0[0], sizeof(a0) div sizeof(ArbFloat) - 1)
-              + spepol(t, a1[0], sizeof(a1) div sizeof(ArbFloat) - 1)
-    end
-  else
-  if x<=2
-  then
-    spebk0:=exp(-x)*spepol(2*x-3, a2[0], sizeof(a2) div sizeof(ArbFloat) - 1)
-  else
-  if x<=4
-  then
-    spebk0:=exp(-x)*spepol(x-3, a3[0], sizeof(a3) div sizeof(ArbFloat) - 1)
-  else
-  if x <= highexp
-  then
-    spebk0:=exp(-x)*
-            spepol(10/(1+x)-1, a4[0], sizeof(a4) div sizeof(ArbFloat) - 1)/sqrt(x)
-  else
-    spebk0:=0
-end; {spebk0}
-
-function spebk1(x: ArbFloat): ArbFloat;
-
-const
-
-   xsmall = 7.9e-10;
-  highexp = 745;
-   a0: array[0..7] of ArbFloat =
-   ( 5.31907865913352762e-1,  3.25725988137110495e-2,
-     6.71642805873498653e-4,  6.95300274548206237e-6,
-     4.32764823642997753e-8,  1.79784792380155752e-10,
-     5.33888268665658944e-13, 1.18964962439910400e-15);
-
-   a1: array[0..7] of ArbFloat =
-   ( 3.51825828289325536e-1,  4.50490442966943726e-2,
-     1.20333585658219028e-3,  1.44612432533006139e-5,
-     9.96686689273781531e-8,  4.46828628435618679e-10,
-     1.40917103024514301e-12, 3.29881058019865600e-15);
-
-   a2: array[0..23] of ArbFloat =
-   ( 1.24316587355255299e+0, -2.71910714388689413e-1,
-     8.20250220860693888e-2, -2.62545818729427417e-2,
-     8.57388087067410089e-3, -2.82450787841655951e-3,
-     9.34594154387642940e-4, -3.10007681013626626e-4,
-     1.02982746700060730e-4, -3.42424912211942134e-5,
-     1.13930169202553526e-5, -3.79227698821142908e-6,
-     1.26265578331941923e-6, -4.20507152338934956e-7,
-     1.40138351985185509e-7, -4.66928912168020101e-8,
-     1.54456653909012693e-8, -5.13783508140332214e-9,
-     1.82808381381205361e-9, -6.15211416898895086e-10,
-     1.28044023949946257e-10, -4.02591066627023831e-11,
-     4.27404330568767242e-11, -1.46639291782948454e-11);
-
-   a3: array[0..23] of ArbFloat =
-   ( 8.06563480128786903e-1,  -1.60052611291327173e-1,
-     4.58591528414023064e-2,  -1.42363136684423646e-2,
-     4.55865751206724687e-3,  -1.48185472032688523e-3,
-     4.85707174778663652e-4,  -1.59994873621599146e-4,
-     5.28712919123131781e-5,  -1.75089594354079944e-5,
-     5.80692311842296724e-6,  -1.92794586996432593e-6,
-     6.40581814037398274e-7,  -2.12969229346310343e-7,
-     7.08723366696569880e-8,  -2.35855618461025265e-8,
-     7.79421651144832709e-9,  -2.59039399308009059e-9,
-     9.20781685906110546e-10, -3.09667392343245062e-10,
-     6.44913423545894175e-11, -2.02680401514735862e-11,
-     2.14736751065133220e-11, -7.36478297050421658e-12);
-
-    a4: array[0..16] of ArbFloat =
-    ( 1.30387573604230402e+0,   5.44845254318931612e-2,
-      4.31639434283445364e-3,   4.29973970898766831e-4,
-      4.04720631528495020e-5,   4.32776409784235211e-6,
-      4.07563856931843484e-7,   4.86651420008153956e-8,
-      3.82717692121438315e-9,   6.77688943857588882e-10,
-      6.97075379117731379e-12,  1.72026097285930936e-11,
-     -2.60774502020271104e-12,  8.58211523713560576e-13,
-     -2.19287104441802752e-13,  1.39321122940600320e-13,
-     -4.77850238111580160e-14);
-
-var t: ArbFloat;
-
-begin
-  if x<=0
-  then
-    RunError(402);
-  if x<=xsmall
-  then
-    spebk1:=1/x
-  else
-  if x<=1
-  then
-    begin
-      t:=2*sqr(x)-1;
-      spebk1:=( ln(x)*spepol(t, a0[0], sizeof(a0) div sizeof(ArbFloat) - 1)
-              -spepol(t, a1[0], sizeof(a1) div sizeof(ArbFloat) -1) )*x + 1/x
-    end
-  else
-  if x<=2
-  then
-    spebk1:=exp(-x)*spepol(2*x-3, a2[0], sizeof(a2) div sizeof(ArbFloat) - 1)
-  else
-  if x<=4
-  then
-    spebk1:=exp(-x)*spepol(x-3, a3[0], sizeof(a3) div sizeof(ArbFloat) - 1)
-  else
-  if x <= highexp
-  then
-    spebk1:=exp(-x)*spepol(10/(1+x)-1, a4[0],
-            sizeof(a4) div sizeof(ArbFloat) - 1)/sqrt(x)
-  else
-    spebk1:=0
-end; {spebk1}
-
-function speby0(x: ArbFloat): ArbFloat;
-
-const
-
-      tbpi = 6.36619772367581343e-1;
-      egam = 5.77215664901532861e-1;
-   xvsmall = 3.2e-9;
-   a1 : array[0..5] of ArbFloat =
-   ( 3.90000000000000000e-19, -8.74734100000000000e-14,
-     5.24879478733000000e-9,  -5.63207914105698700e-5,
-     4.71966895957633869e-2,   1.79034314077182663e-1);
-
-   b1 : array[0..5] of ArbFloat =
-   ( -2.69800000000000000e-17, 4.02633082000000000e-12,
-     -1.44072332740190000e-7,  7.53113593257774230e-4,
-     -1.77302012781143582e-1, -2.74474305529745265e-1);
-
-   c1 : array[0..5] of ArbFloat =
-   ( 1.64349000000000000e-15, -1.58375525420000000e-10,
-     3.20653253765480000e-6,  -7.28796247955207918e-3,
-     2.61567346255046637e-1,  -3.31461132032849417e-2);
-
-    d1 : array[0..13] of ArbFloat =
-    ( 9.99457275788251954e-1, -5.36367319213004570e-4,
-      6.13741608010926000e-6, -2.05274481565160000e-7,
-      1.28037614434400000e-8, -1.21211819632000000e-9,
-      1.55005642880000000e-10,-2.48827276800000000e-11,
-      4.78702080000000000e-12,-1.06365696000000000e-12,
-      2.45294080000000000e-13,-6.41843200000000000e-14,
-      3.34028800000000000e-14,-1.17964800000000000e-14);
-
-    d2 : array[0..16] of ArbFloat =
-    (-1.55551138795135187e-2,  6.83314909934390000e-5,
-     -1.47713883264594000e-6,  7.10621485930000000e-8,
-     -5.66871613024000000e-9,  6.43278173280000000e-10,
-     -9.47034774400000000e-11, 1.70330918400000000e-11,
-     -3.59094272000000000e-12, 8.59855360000000000e-13,
-     -2.28807680000000000e-13, 6.95193600000000000e-14,
-     -2.27942400000000000e-14, 4.75136000000000000e-15,
-     -1.14688000000000000e-15, 2.12992000000000000e-15,
-     -9.83040000000000000e-16);
-
-var t, g, y, t2, a, b, c, cx, sx : ArbFloat;
-    i, bov                       : ArbInt;
-
-begin
-  if x<=0
-  then
-    RunError(403);
-  if x<=xvsmall
-  then
-    speby0:=(ln(x/2)+egam)*tbpi
-  else
-  if x<=8
-  then
-    begin
-      t:=0.03125*sqr(x)-1; t2:=2*t;
-      b:=0; c:=0;
-      bov:=sizeof(a1) div sizeof(ArbFloat) - 1;
-      for i:=0 to bov do
-        begin
-          a:=t2*c-b+a1[i];
-          b:=t2*a-c+b1[i];
-          if i<bov
-          then
-            c:=t2*b-a+c1[i]
-          else
-            speby0:=t*b-a+c1[i]+tbpi*spebj0(x)*ln(x)
-        end {i}
-    end {x<=8}
-  else
-    begin
-      g:=x-1/(2*tbpi); y:=sqrt(tbpi/x);
-      cx:=cos(g)*y*8/x; sx:=sin(g)*y;
-      t:=128/sqr(x)-1;
-      speby0:=sx*spepol(t, d1[0], sizeof(d1) div sizeof(ArbFloat) - 1)
-            + cx*spepol(t, d2[0], sizeof(d2) div sizeof(ArbFloat) - 1)
-    end {x>8}
-end {speby0};
-
-function speby1(x: ArbFloat): ArbFloat;
-
-const
-    tbpi = 6.36619772367581343e-1;
-    xsmall = 7.9e-10;
-   a1 : array[0..5] of ArbFloat =
-   (-6.58000000000000000e-18, 1.21143321000000000e-12,
-    -5.68844003991900000e-8,  4.40478629867099510e-4,
-    -2.26624991556754924e-1, -1.28697384381350001e-1);
-
-   b1 : array[0..5] of ArbFloat =
-   ( 4.27730000000000000e-16,-5.17212147300000000e-11,
-     1.41662436449235000e-6, -5.13164116106108479e-3,
-     6.75615780772187667e-1,  2.03041058859342538e-2);
-
-   c1 : array[0..4] of ArbFloat =
-   (-2.44094900000000000e-14, 1.87547032473000000e-9,
-    -2.83046401495148000e-5,  4.23191803533369041e-2,
-    -7.67296362886645940e-1);
-    
-   d1 : array[0..13] of ArbFloat =
-   ( 1.00090702627808217e+0,  8.98804941670557880e-4,
-    -7.95969469843846000e-6,  2.45367662227560000e-7,
-    -1.47085129889600000e-8,  1.36030580128000000e-9,
-    -1.71310758400000000e-10, 2.72040729600000000e-11,
-    -5.19113984000000000e-12, 1.14622464000000000e-12,
-    -2.63372800000000000e-13, 6.86387200000000000e-14,
-    -3.54508800000000000e-14, 1.24928000000000000e-14);
-
-    d2 : array[0..15] of ArbFloat =
-    ( 4.67768740274489776e-2, -9.62145882205441600e-5,
-      1.82120185123076000e-6, -8.29196070929200000e-8,
-      6.42013250344000000e-9, -7.15110504800000000e-10,
-      1.03950931840000000e-10,-1.85248000000000000e-11,
-      3.87554432000000000e-12,-9.23228160000000000e-13,
-      2.50224640000000000e-13,-7.43936000000000000e-14,
-      1.75718400000000000e-14,-4.83328000000000000e-15,
-      5.32480000000000000e-15,-2.29376000000000000e-15);
-
-var t, g, y, t2, a, b, c, cx, sx : ArbFloat;
-    i, bov                       : ArbInt;
-
-begin
-  if x<=0
-  then
-    RunError(404);
-  if x<=xsmall
-  then
-    speby1:=-tbpi/x
-  else
-  if x<=8
-  then
-    begin
-      t:=0.03125*sqr(x)-1; t2:=2*t;
-      b:=0; c:=0;
-      bov:=sizeof(a1) div sizeof(ArbFloat) - 1;
-      for i:=0 to bov do
-        begin
-          a:=t2*c-b+a1[i];
-          if i<bov
-          then
-            begin
-              b:=t2*a-c+b1[i];
-              c:=t2*b-a+c1[i]
-            end
-          else
-          if bov=3   {single}
-          then
-            begin
-              b:=t2*a-c+b1[i];
-              speby1:=(t*b-a+c1[i])*x/8 + spebj1(x)*ln(x)*tbpi - tbpi/x
-            end
-          else
-            speby1:=(t*a-c+b1[i])*x/8 + spebj1(x)*ln(x)*tbpi - tbpi/x
-        end {i}
-    end {x<=8}
-  else
-    begin
-      g:=x-3/(2*tbpi); y:=sqrt(tbpi/x);
-      cx:=cos(g)*y*8/x; sx:=sin(g)*y;
-      t:=128/sqr(x)-1;
-      speby1:=sx*spepol(t, d1[0], sizeof(d1) div sizeof(ArbFloat) - 1)
-            + cx*spepol(t, d2[0], sizeof(d2) div sizeof(ArbFloat) - 1)
-    end {x>8}
-end {speby1};
-
-function speent(x : ArbFloat): longint;
-
-var tx : longint;
-
-begin
-  tx:=trunc(x);
-  if x>=0
-  then
-    speent:=tx
-  else
-    if x=tx
-    then
-      speent:=tx
-    else
-      speent:=tx-1
-end; {speent}
-
-function speerf(x : ArbFloat) : ArbFloat;
-const
-
-        xup = 6.25;
-     sqrtpi = 1.7724538509055160;
-     c : array[1..18] of ArbFloat =
-     ( 1.9449071068178803e0,  4.20186582324414e-2, -1.86866103976769e-2,
-       5.1281061839107e-3,   -1.0683107461726e-3,   1.744737872522e-4,
-      -2.15642065714e-5,      1.7282657974e-6,     -2.00479241e-8,
-      -1.64782105e-8,         2.0008475e-9,         2.57716e-11,
-      -3.06343e-11,           1.9158e-12,           3.703e-13,
-      -5.43e-14,             -4.0e-15,              1.2e-15);
-
-     d : array[1..17] of ArbFloat =
-     ( 1.4831105640848036e0, -3.010710733865950e-1, 6.89948306898316e-2,
-      -1.39162712647222e-2,   2.4207995224335e-3,  -3.658639685849e-4,
-       4.86209844323e-5,     -5.7492565580e-6,      6.113243578e-7,
-      -5.89910153e-8,         5.2070091e-9,        -4.232976e-10,
-       3.18811e-11,          -2.2361e-12,           1.467e-13,
-      -9.0e-15,               5.0e-16);
-
-  var t, s, s1, s2, x2: ArbFloat;
-         bovc, bovd, j: ArbInt;
-begin
-  bovc:=sizeof(c) div sizeof(ArbFloat);
-  bovd:=sizeof(d) div sizeof(ArbFloat);
-  t:=abs(x);
-  if t <= 2
-  then
-    begin
-      x2:=sqr(x)-2;
-      s1:=d[bovd]; s2:=0; j:=bovd-1;
-      s:=x2*s1-s2+d[j];
-      while j > 1 do
-        begin
-          s2:=s1; s1:=s; j:=j-1;
-          s:=x2*s1-s2+d[j]
-        end;
-      speerf:=(s-s2)*x/2
-    end
-  else
-    if t < xup
-    then
-      begin
-        x2:=2-20/(t+3);
-        s1:=c[bovc]; s2:=0; j:=bovc-1;
-        s:=x2*s1-s2+c[j];
-        while j > 1 do
-          begin
-            s2:=s1; s1:=s; j:=j-1;
-            s:=x2*s1-s2+c[j]
-          end;
-        x2:=((s-s2)/(2*t))*exp(-sqr(x))/sqrtpi;
-        speerf:=(1-x2)*spesgn(x)
-      end
-    else
-      speerf:=spesgn(x)
-end;  {speerf}
-
-function spemax(a, b: ArbFloat): ArbFloat;
-begin
-  if a>b
-  then
-    spemax:=a
-  else
-    spemax:=b
-end; {spemax}
-
-function speefc(x : ArbFloat) : ArbFloat;
-const
-
-   xlow = -6.25;
-  xhigh = 27.28;
-      c : array[0..22] of ArbFloat =
-      ( 1.455897212750385e-1, -2.734219314954260e-1,
-        2.260080669166197e-1, -1.635718955239687e-1,
-        1.026043120322792e-1, -5.480232669380236e-2,
-        2.414322397093253e-2, -8.220621168415435e-3,
-        1.802962431316418e-3, -2.553523453642242e-5,
-       -1.524627476123466e-4,  4.789838226695987e-5,
-        3.584014089915968e-6, -6.182369348098529e-6,
-        7.478317101785790e-7,  6.575825478226343e-7,
-       -1.822565715362025e-7, -7.043998994397452e-8,
-        3.026547320064576e-8,  7.532536116142436e-9,
-       -4.066088879757269e-9, -5.718639670776992e-10,
-        3.328130055126039e-10);
-
-  var t, s : ArbFloat;
-begin
-  if x <= xlow
-  then
-    speefc:=2
-  else
-  if x >= xhigh
-  then
-    speefc:=0
-  else
-    begin
-      t:=1-7.5/(abs(x)+3.75);
-      s:=exp(-x*x)*spepol(t, c[0], sizeof(c) div sizeof(ArbFloat) - 1);
-      if x < 0
-      then
-        speefc:=2-s
-      else
-        speefc:=s
-    end
-end {speefc};
-
-function spegam(x: ArbFloat): ArbFloat;
-const
-
-    tmax = 170;
-    a: array[0..23] of ArbFloat =
-    ( 8.86226925452758013e-1,  1.61691987244425092e-2,
-      1.03703363422075456e-1, -1.34118505705967765e-2,
-      9.04033494028101968e-3, -2.42259538436268176e-3,
-      9.15785997288933120e-4, -2.96890121633200000e-4,
-      1.00928148823365120e-4, -3.36375833240268800e-5,
-      1.12524642975590400e-5, -3.75499034136576000e-6,
-      1.25281466396672000e-6, -4.17808776355840000e-7,
-      1.39383522590720000e-7, -4.64774927155200000e-8,
-      1.53835215257600000e-8, -5.11961333760000000e-9,
-      1.82243164160000000e-9, -6.13513953280000000e-10,
-      1.27679856640000000e-10,-4.01499750400000000e-11,
-      4.26560716800000000e-11,-1.46381209600000000e-11);
-
-var tvsmall, t, g: ArbFloat;
-             m, i: ArbInt;
-begin
-  if sizeof(ArbFloat) = 6
-  then
-    tvsmall:=2*midget
-  else
-    tvsmall:=midget;
-  t:=abs(x);
-  if t > tmax
-  then
-    RunError(407);
-  if t < macheps
-  then
-    begin
-      if t < tvsmall
-      then
-        RunError(407);
-      spegam:=1/x
-    end
-  else  { abs(x) >= macheps }
-    begin
-      m:=trunc(x);
-      if x > 0
-      then
-        begin
-          t:=x-m; m:=m-1; g:=1;
-          if m<0
-          then
-            g:=g/x
-          else
-            if m>0
-            then
-              for i:=1 to m do
-                g:=(x-i)*g
-        end
-      else { x < 0 }
-        begin
-          t:=x-m+1;
-          if t=1
-          then
-            RunError(407);
-          m:=1-m;
-          g:=x;
-          for i:=1 to m do
-            g:=(i+x)*g;
-          g:=1/g
-        end;
-      spegam:=spepol(2*t-1, a[0], sizeof(a) div sizeof(ArbFloat) - 1)*g
-    end { abs(x) >= macheps }
-end; {spegam}
-
-function spelga(x: ArbFloat): ArbFloat;
-
-const
-
-    xbig = 7.7e7;
-    xmax = 2.559e305;
-  lnr2pi = 9.18938533204672742e-1;
-    a: array[0..23] of ArbFloat =
-    ( 8.86226925452758013e-1,  1.61691987244425092e-2,
-      1.03703363422075456e-1, -1.34118505705967765e-2,
-      9.04033494028101968e-3, -2.42259538436268176e-3,
-      9.15785997288933120e-4, -2.96890121633200000e-4,
-      1.00928148823365120e-4, -3.36375833240268800e-5,
-      1.12524642975590400e-5, -3.75499034136576000e-6,
-      1.25281466396672000e-6, -4.17808776355840000e-7,
-      1.39383522590720000e-7, -4.64774927155200000e-8,
-      1.53835215257600000e-8, -5.11961333760000000e-9,
-      1.82243164160000000e-9, -6.13513953280000000e-10,
-      1.27679856640000000e-10,-4.01499750400000000e-11,
-      4.26560716800000000e-11,-1.46381209600000000e-11);
-    b: array[0..5] of ArbFloat =
-    ( 8.33271644065786580e-2,  -6.16502049453716986e-6,
-      3.89978899876484712e-9,  -6.45101975779653651e-12,
-      2.00201927337982364e-14, -9.94561064728159347e-17);
-
-
-var t, g : ArbFloat;
-    m, i : ArbInt;
-
-begin
-  if x <= 0
-  then
-    RunError(408);
-  if x <= macheps
-  then
-    spelga:=-ln(x)
-  else
-  if x <= 15
-  then
-    begin
-      m:=trunc(x); t:=x-m; m:=m-1; g:=1;
-      if m < 0
-      then
-        g:=g/x
-      else
-      if m > 0
-      then
-        for i:=1 to m do
-          g:=(x-i)*g;
-      spelga:=ln(g*spepol(2*t-1, a[0], sizeof(a) div sizeof(ArbFloat) - 1))
-    end
-  else { x > 15 }
-  if x <= xbig
-  then
-    spelga:=(x-0.5)*ln(x) - x + lnr2pi
-            + spepol(450/sqr(x)-1, b[0], sizeof(b) div sizeof(ArbFloat) - 1)/x
-  else { x > xbig }
-  if x <= xmax
-  then
-    spelga:=(x-0.5)*ln(x) - x + lnr2pi
-  else  { x > xmax => x*ln(x) > giant }
-    RunError(408)
-end; {spelga}
-
-function spepol(x: ArbFloat; var a: ArbFloat; n: ArbInt): ArbFloat;
-var   pa : ^arfloat0;
-       i : ArbInt;
-    polx : ArbFloat;
-begin
-  pa:=@a;
-  polx:=0;
-  for i:=n downto 0 do
-    polx:=polx*x+pa^[i];
-  spepol:=polx
-end {spepol};
-
-function spepow(a, b: ArbFloat): ArbFloat;
-
-   function PowInt(a: double; n: longint): double;
-   var a1 : double;
-   begin
-     if n=0 then PowInt := 1 else
-     begin
-        a1 := 1;
-        if n<0 then begin a := 1/a; n := -n end;
-        while n>0
-        do if Odd(n)
-           then begin Dec(n); a1 := a1*a end
-           else begin n := n div 2; a := sqr(a) end;
-        PowInt := a1
-     end
-   end;
-
-var tb : longint;
-    fb : double;
-begin
-
-  { (a < 0, b niet geheel) of (a = 0, b <= 0), dan afbreken}
-  if (a=0) then if (b<=0) then RunError(400) else begin SpePow :=0; exit end;
-  tb := Trunc(b); fb := b-tb;
-  if (a<0) and (fb<>0) then RunError(400);
-
-  if a>0
-  then if fb=0 then SpePow := PowInt(a, tb)
-               else SpePow := PowInt(a, tb)*exp(fb*ln(a))
-  else if odd(tb) then Spepow := -PowInt(-a, tb)
-                  else SpePow := PowInt(-a, tb)
-
-end; {spepow}
-
-function spesgn(x: ArbFloat): ArbInt;
-
-begin
-  if x<0
-  then
-    spesgn:=-1
-  else
-    if x=0
-    then
-      spesgn:=0
-    else
-      spesgn:=1
-end; {spesgn}
-
-function spears(x: ArbFloat): ArbFloat;
-const
-
-    pi2 = 1.570796326794897;
-    a : array[0..17] of ArbFloat =
-    (  1.047197551196598e+0, 5.375149359132719e-2, 7.798902238957732e-3,
-       1.519668539582420e-3, 3.408637238430600e-4, 8.302317819598986e-5,
-       2.134554822576075e-5, 5.701781046148566e-6, 1.566985123962741e-6,
-       4.402076871418002e-7, 1.257811162594110e-7, 3.646577948300129e-8,
-       1.081021746966715e-8, 3.212744286269388e-9, 8.515014302985799e-10,
-       2.513296398553196e-10, 1.342121568282535e-10, 4.210346761190271e-11);
-
-var    y, u, t, s : ArbFloat;
-    uprang        : boolean;
-begin
-  if abs(x) > 1
-  then
-    RunError(401);
-  u:=sqr(x); uprang:= u > 0.5;
-  if uprang
-  then
-    u:=1-u;
-  t:=4*u-1; y:=spepol(t, a[0], sizeof(a) div sizeof(ArbFloat) - 1);
-  if uprang
-  then
-    begin
-      s:=pi2-sqrt(u)*y;
-      if x < 0
-      then
-        s:=-s;
-      spears:=s
-    end
-  else
-    spears:=x*y
-end;  {spears}
-
-function spearc(x: ArbFloat): ArbFloat;
-const
-
-    pi2 = 1.570796326794897;
-    a : array[0..17] of ArbFloat =
-    ( 1.047197551196598e+0,  5.375149359132719e-2,  7.798902238957732e-3,
-      1.519668539582420e-3,  3.408637238430600e-4,  8.302317819598986e-5,
-      2.134554822576075e-5,  5.701781046148566e-6,  1.566985123962741e-6,
-      4.402076871418002e-7,  1.257811162594110e-7,  3.646577948300129e-8,
-      1.081021746966715e-8,  3.212744286269388e-9,  8.515014302985799e-10,
-      2.513296398553196e-10, 1.342121568282535e-10, 4.210346761190271e-11);
-
-var u, t, y, s    : ArbFloat;
-    uprang        : boolean;
-begin
-  if abs(x)>1.0
-  then
-    RunError(402);
-  u:=sqr(x); uprang:=u>0.5;
-  if uprang
-  then
-    u:=1-u;
-  t:=4*u-1; y:=spepol(t, a[0], sizeof(a) div sizeof(ArbFloat) - 1);
-  if uprang
-  then
-    begin
-      s:=sqrt(u)*y;
-      if x<0
-      then
-        s:=2*pi2-s;
-      spearc:=s
-    end
-  else
-    spearc:=pi2-x*y
-end;  {spearc}
-
-function spesih(x: ArbFloat): ArbFloat;
-const
-
-    a : array[0..6] of ArbFloat =
-    ( 1.085441641272607e+0,  8.757509762437522e-2,  2.158779361257021e-3,
-      2.549839945498292e-5,  1.761854853281383e-7,  7.980704288665359e-10,
-      2.551377137317034e-12);
-
-var u : ArbFloat;
-begin
-  if abs(x)<=1.0
-  then
-    begin
-      u:=2*sqr(x)-1;
-      spesih:=x*spepol(u, a[0], sizeof(a) div sizeof(ArbFloat) - 1)
-    end
-  else
-  begin
-    u:=exp(x); spesih:=(u-1/u)/2
-  end
-end; {spesih}
-
-function specoh(x: ArbFloat): ArbFloat;
-var u: ArbFloat;
-begin
-  u:=exp(x); specoh:=(u+1/u)/2
-end; {specoh}
-
-function spetah(x: ArbFloat): ArbFloat;
-const
-    xhi = 18.50;
-    a : array[0..15] of ArbFloat =
-    ( 8.610571715805476e-1, -1.158834489728470e-1,  1.918072383973950e-2,
-     -3.225255180728459e-3,  5.433071386922689e-4, -9.154289983175165e-5,
-      1.542469328074432e-5, -2.599022539340038e-6,  4.379282308765732e-7,
-     -7.378980192173815e-8,  1.243517352745986e-8, -2.095373768837420e-9,
-      3.509758916273561e-10,-5.908745181531817e-11, 1.124199312776748e-11,
-     -1.907888434471600e-12);
-
-var t, y: ArbFloat;
-
-begin
-  t:=abs(x);
-  if t <= 1
-  then
-    begin
-      y:=2*sqr(x)-1;
-      spetah:=x*spepol(y, a[0], sizeof(a) div sizeof(ArbFloat) - 1)
-    end
-  else
-  if t < xhi
-  then
-    begin
-      y:=exp(2*x); spetah:=(y-1)/(y+1)
-    end
-  else
-    spetah:=spesgn(x)
-end; {spetah}
-
-function speash(x: ArbFloat): ArbFloat;
-const
-
-    xhi = 1e9;
-    c : array[0..18] of ArbFloat =
-    (  9.312298594527122e-1,  -5.736663926249348e-2,
-       9.004288574881897e-3,  -1.833458667045431e-3,
-       4.230023450529706e-4,  -1.050715136470630e-4,
-       2.740790473603819e-5,  -7.402952157663977e-6,
-       2.052474396638805e-6,  -5.807433412373489e-7,
-       1.670117348345774e-7,  -4.863477336087045e-8,
-       1.432753532351304e-8,  -4.319978113584910e-9,
-       1.299779213740398e-9,  -3.394726871170490e-10,
-       1.008344962167889e-10, -5.731943029121004e-11,
-       1.810792296549804e-11);
-
-
-var t : ArbFloat;
-
-begin
-  t:=abs(x);
-  if t <= 1 then
-    speash:=x*spepol(2*sqr(x)-1, c[0], sizeof(c) div sizeof(ArbFloat) - 1)
-  else
-  if t < xhi then
-    speash:=ln(sqrt(sqr(x)+1)+t)*spesgn(x)
-  else
-    speash:=ln(2*t)*spesgn(x)
-end; {speash}
-
-function speach(x: ArbFloat): ArbFloat;
-const
-
-    xhi = 1e9;
-
-begin
-  if x<1 then
-    RunError(405);
-  if x=1 then
-    speach:=0
-  else
-  if x<=xhi then
-    speach:=ln(x+sqrt(sqr(x)-1))
-  else
-    speach:=ln(2*x)
-end; {speach}
-
-function speath(x: ArbFloat): ArbFloat;
-const
-
-    c : array[0..19] of ArbFloat =
-    ( 1.098612288668110e+0,  1.173605223326117e-1,  2.309071936165689e-2,
-      5.449091889986991e-3,  1.404884102286929e-3,  3.816948426588058e-4,
-      1.073604335435426e-4,  3.095027782918129e-5,  9.088050814470148e-6,
-      2.706881064641104e-6,  8.155200644023077e-7,  2.479830612463254e-7,
-      7.588067811453948e-8,  2.339295963220429e-8,  7.408486568719348e-9,
-      2.319454882064018e-9,  5.960921368486746e-10, 1.820410351379402e-10,
-      1.184977617320312e-10, 3.856235316559190e-11);
-
-var t, u: ArbFloat;
-begin
-  t:=abs(x);
-  if t >= 1 then
-    RunError(406);
-  u:=sqr(x);
-  if u < 0.5 then
-    speath:=x*spepol(4*u-1, c[0], sizeof(c) div sizeof(ArbFloat) - 1)
-  else { 0.5 < x*x < 1 }
-    speath:=ln((1+t)/(1-t))/2*spesgn(x)
-end; {speath}
-
-var exitsave : pointer;
-
-procedure MyExit; Far;
-const ErrorS : array[400..408,1..6] of char =
-     ('spepow',
-      'spebk0',
-      'spebk1',
-      'speby0',
-      'speby1',
-      'speach',
-      'speath',
-      'spegam',
-      'spelga');
-
-var ErrFil : text;
-
-begin
-     ExitProc := ExitSave;
-     Assign(ErrFil, 'CON');
-     ReWrite(ErrFil);
-     if (ExitCode>=400) AND (ExitCode<=408) then
-       begin
-         write(ErrFil, 'critical error in ', ErrorS[ExitCode]);
-         ExitCode := 201
-       end;
-     Close(ErrFil)
-end;
-
-begin
-   ExitSave := ExitProc;
-   ExitProc := @MyExit;
-end.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:46  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:16  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/spl.pas

@@ -1,1130 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    Undocumented unit. B- and other Splines. Not imported by the other units
-    afaik.
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-unit spl;
-{$I direct.inc}
-
-interface
-
-uses typ, sle;
-
-function  spl1bspv(q: ArbInt; var kmin1, c1: ArbFloat; x: ArbFloat; var term: ArbInt): ArbFloat;
-function  spl2bspv(qx, qy: ArbInt; var kxmin1, kymin1, c11: ArbFloat; x, y: ArbFloat; var term: ArbInt): ArbFloat;
-procedure spl1bspf(M, Q: ArbInt; var XYW1: ArbFloat;
-                 var Kmin1, C1, residu: ArbFloat;
-                 var term: ArbInt);
-procedure spl2bspf(M, Qx, Qy: ArbInt; var XYZW1: ArbFloat;
-                 var Kxmin1, Kymin1, C11, residu: ArbFloat;
-                 var term: ArbInt);
-procedure spl1nati(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
-procedure spl1naki(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
-procedure spl1cmpi(n: ArbInt; var xyc1: ArbFloat; dy1, dyn: ArbFloat;
-                 var term: ArbInt);
-procedure spl1peri(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
-function  spl1pprv(n: ArbInt; var xyc1: ArbFloat; t: ArbFloat; var term: ArbInt): ArbFloat;
-
-procedure spl1nalf(n: ArbInt; var xyw1: ArbFloat; lambda:ArbFloat;
-                     var xac1, residu: ArbFloat; var term: ArbInt);
-function spl2natv(n: ArbInt; var xyg0: ArbFloat; u, v: ArbFloat): ArbFloat;
-procedure spl2nalf(n: ArbInt; var xyzw1: ArbFloat; lambda:ArbFloat;
-                     var xyg0, residu: ArbFloat; var term: ArbInt);
-      { term = 1: succes,
-        term = 2: set linear equations is not "PD"
-        term = 4: Approx. number of points? On a line.
-        term = 3: wrong input n<3 or a weight turned out to be <=0 }
-implementation
-
-type
-    Krec = record K1, K2, K3, K4, K5, K6 : ArbFloat end;
-
-function spl1bspv(q: ArbInt; var kmin1, c1: ArbFloat; x: ArbFloat; var term: ArbInt): ArbFloat;
-var c    : arfloat1 absolute c1;
-    k    : arfloat_1 absolute kmin1;
-    D1, D2, D3,
-    E2, E3, E4, E5: ArbFloat;
-    pk   : ^Krec;
-    l, r, m : ArbInt;
-begin
-    spl1bspv := NaN;
-    term := 3;                           { q >=4 !     }
-    if q<4 then exit;                    { at least 1 interval   }
-    if (x<k[2]) or (x>k[q-1]) then exit; { x inside the interval }
-    term := 1;                           { Let's hope the params are good :-)}
-    l := 2; r := q-1;
-    while l+1<r do                       { after this loop goes: }
-     begin                                { k[l]<=x<=k[l+1] with  }
-      m := (l+r) div 2;                {   k[l] < k[l+1]       }
-      if x>=k[m] then l := m else r := m
-     end;
-    pk := @k[l-2];                       { the (de) Boor algoritm ..  }
-    with pk^ do
-     begin
-      E2 := X - K2; E3 := X - K3; E4 := K4 - X; E5 := K5 - X;
-      D2 := C[l]; D3 := C[l+1];
-      D1 := ((X-K1)*D2+E4*C[l-1])/(K4-K1);
-      D2 := (E2*D3+E5*D2)/(K5-K2);
-      D3 := (E3*C[l+2]+(K6-X)*D3)/(K6-K3);
-      D1 := (E2*D2+E4*D1)/(K4-K2);
-      D2 := (E3*D3+E5*D2)/(K5-K3);
-      spl1bspv := (E3*D2+E4*D1)/(K4-K3)
-    end;
-end;
-
-function  spl2bspv(qx, qy: ArbInt; var kxmin1, kymin1, c11: ArbFloat; x, y: ArbFloat; var term: ArbInt): ArbFloat;
-var  pd: ^arfloat1;
-  i, iy: ArbInt;
-      c: arfloat1 absolute c11;
-begin
-    GetMem(pd, qx*SizeOf(ArbFloat));
-    i := 0;
-    iy := 1;
-    repeat
-        i := i + 1;
-        pd^[i] := spl1bspv(qy, kymin1, c[iy], y, term);
-        Inc(iy, qy)
-    until (i=qx) or (term<>1);
-    if term=1
-    then spl2bspv := spl1bspv(qx, kxmin1, pd^[1], x, term)
-    else spl2bspv := NaN;
-    FreeMem(pd, qx*SizeOf(ArbFloat));
-end;
-
-(*  Bron: NAG LIBRARY SUBROUTINE  E02BAF *)
-
-function Imin(x, y: ArbInt): ArbInt;
-begin if x<y then Imin := x else Imin := y end;
-
-type ar4 = array[1..$ffe0 div (4*SizeOf(ArbFloat)),1..4] of ArbFloat;
-     ar3 = array[1..$ffe0 div (3*SizeOf(ArbFloat)),1..3] of ArbFloat;
-     r_3 = record x, y, w: ArbFloat end;
-     r3Ar= array[1..$ffe0 div SizeOf(r_3)] of r_3;
-     r_4 = record x, y, z, w: ArbFloat end;
-     r4Ar= array[1..$ffe0 div SizeOf(r_4)] of r_4;
-     r4  = array[1..4] of ArbFloat;
-     r2  = array[1..2] of ArbFloat;
-
-     r4x  = record xy: R2; alfa, d: ArbFloat end;
-     r4xAr= array[1..$ffe0 div SizeOf(r4x)] of r4x;
-     nsp2rec = array[0..$ff80 div (3*SizeOf(ArbFloat))] of
-               record xy: R2; gamma: ArbFloat end;
-
-procedure spl1bspf(M, Q: ArbInt; var XYW1: ArbFloat;
-                 var Kmin1, C1, residu: ArbFloat;
-                 var term: ArbInt);
-var work1: ^arfloat1;
-    work2: ^ar4;
-    c    : arfloat1 absolute c1;
-    k    : arfloat_1 absolute kmin1;
-    xyw  : r3Ar absolute XYW1;
-    r, j, jmax, l, lplus1, i, iplusj, jold, jrev,
-    jplusl, iu, lplusu : ArbInt;
-    s, k0, k4, sigma,
-    d, d4, d5, d6, d7, d8, d9,
-    e2, e3, e4, e5,
-    n1, n2, n3,
-    relemt, dprime, cosine, sine,
-    acol, arow, crow, ccol, ss     : ArbFloat;
-    pk   : ^Krec;
-
-label einde;
-(*
-      DOUBLE PRECISION  C(NCAP7), K(NCAP7), W(M), WORK1(M),
-     *                  WORK2(4,NCAP7), X(M), Y(M)
-     .. Local Scalars ..
-      DOUBLE PRECISION  ACOL, AROW, CCOL, COSINE, CROW, D, D4, D5, D6,
-     *                  D7, D8, D9, DPRIME, E2, E3, E4, E5, K0, K1, K2,
-     *                  K3, K4, K5, K6, N1, N2, N3, RELEMT, S, SIGMA,
-     *                  SINE, WI, XI
-      INTEGER           I, IERROR, IPLUSJ, IU, J, JOLD, JPLUSL, JREV, L,
-     *                  L4, LPLUS1, LPLUSU, NCAP, NCAP3, NCAPM1, R
-*)
-begin
-    term := 3;
-    if q<4 then exit;
-    if m<q then exit;
-(*
-     CHECK THAT THE VALUES OF  M  AND  NCAP7  ARE REASONABLE
-      IF (NCAP7.LT.8 .OR. M.LT.NCAP7-4) GO TO 420
-      NCAP = NCAP7 - 7
-      NCAPM1 = NCAP - 1
-      NCAP3 = NCAP + 3
-
-     IN ORDER TO DEFINE THE FULL B-SPLINE BASIS, AUGMENT THE
-     PRESCRIBED INTERIOR KNOTS BY KNOTS OF MULTIPLICITY FOUR
-     AT EACH END OF THE DATA RANGE.
-
-*)
-    for j:=-1 to 2 do k[j] := xyw[1].x;
-    for j:=q-1 to q+2 do k[j] := xyw[m].x;
-
-    if (k[3]<=xyw[1].x) or (k[q-2]>=xyw[m].x) then exit;
-(*
-     CHECK THAT THE KNOTS ARE ORDERED AND ARE INTERIOR
-     TO THE DATA INTERVAL.
-*)
-    j := 3; while (k[j]<=k[j+1]) and (j<q-2) do Inc(j);
-    if j<q-2 then exit;
-(*
-     CHECK THAT THE WEIGHTS ARE STRICTLY POSITIVE.
-*)
-    j := 1;
-    while (xyw[j].w>0) and (j<m) do Inc(j);
-    if xyw[j].w<=0 then exit;
-(*
-     CHECK THAT THE DATA ABSCISSAE ARE ORDERED, THEN FORM THE
-     ARRAY  WORK1  FROM THE ARRAY  X.  THE ARRAY  WORK1  CONTAINS
-     THE
-     SET OF DISTINCT DATA ABSCISSAE.
-*)
-    GetMem(Work1, m*SizeOf(ArbFloat));
-    GetMem(Work2, q*4*SizeOf(ArbFloat));
-    r := 1; work1^[1] := xyw[1].x;
-    j := 1;
-    while (j<m) do
-    begin
-       Inc(j);
-       if xyw[j].x>work1^[r]
-       then begin Inc(r); work1^[r] := xyw[j].x end
-       else if xyw[j].x<work1^[r] then goto einde;
-    end;
-    if r<q then goto einde;
-
-(*
-     CHECK THE FIRST  S  AND THE LAST  S  SCHOENBERG-WHITNEY
-     CONDITIONS ( S = MIN(NCAP - 1, 4) ).
-*)
-    jmax := Imin(q-4,4);
-    j := 1;
-    while (j<=jmax) do
-    begin
-      if (work1^[j]>=k[j+2]) or (k[q-j-1]>=work1^[r-j+1]) then goto einde;
-      Inc(j)
-    end;
-(*
-     CHECK ALL THE REMAINING SCHOENBERG-WHITNEY CONDITIONS.
-*)
-    Dec(r, 4); i := 4; j := 5;
-    while j<=q-4 do
-    begin
-       K0 := K[j+2]; K4 := K[J-2];
-       repeat Inc(i) until (Work1^[i]>k4);
-       if (I>R) or (WORK1^[I]>=K0) then goto einde;
-       Inc(j)
-    end;
-
-(*
-     INITIALISE A BAND TRIANGULAR SYSTEM (I.E. A
-     MATRIX AND A RIGHT HAND SIDE) TO ZERO. THE
-     PROCESSING OF EACH DATA POINT IN TURN RESULTS
-     IN AN UPDATING OF THIS SYSTEM. THE SUBSEQUENT
-     SOLUTION OF THE RESULTING BAND TRIANGULAR SYSTEM
-     YIELDS THE COEFFICIENTS OF THE B-SPLINES.
-*)
-    FillChar(Work2^, q*4*SizeOf(ArbFloat), 0);
-    FillChar(c, q*SizeOf(ArbFloat), 0);
-
-    SIGMA := 0; j := 0; jold := 0;
-    for i:=1 to m do
-    with xyw[i] do
-    begin
-(*
-        FOR THE DATA POINT  (X(I), Y(I))  DETERMINE AN INTERVAL
-        K(J + 3) .LE. X .LT. K(J + 4)  CONTAINING  X(I).  (IN THE
-        CASE  J + 4 .EQ. NCAP  THE SECOND EQUALITY IS RELAXED TO
-        INCLUDE
-        EQUALITY).
-*)
-       while (x>=k[j+2]) and (j<=q-4) do Inc(j);
-       if j<>jold then
-       begin
-         pk := @k[j-1];
-         with pk^ do
-         begin
-             D4 := 1/(K4-K1); D5 := 1/(K5-K2); D6 := 1/(K6-K3);
-             D7 := 1/(K4-K2); D8 := 1/(K5-K3); D9 := 1/(K4-K3)
-         end;
-         JOLD := J;
-       end;
-(*
-        COMPUTE AND STORE IN  WORK1(L) (L = 1, 2, 3, 4)  THE VALUES
-        OF
-        THE FOUR NORMALIZED CUBIC B-SPLINES WHICH ARE NON-ZERO AT
-        X=X(I).
-*)     with pk^ do
-       begin
-           E5 := k5 - X;
-           E4 := K4 - X;
-           E3 := X - K3;
-           E2 := X - K2;
-           N1 := W*D9;
-           N2 := E3*N1*D8;
-           N1 := E4*N1*D7;
-           N3 := E3*N2*D6;
-           N2 := (E2*N1+E5*N2)*D5;
-           N1 := E4*N1*D4;
-           WORK1^[4] := E3*N3;
-           WORK1^[3] := E2*N2 + (K6-X)*N3;
-           WORK1^[2] := (X-K1)*N1 + E5*N2;
-           WORK1^[1] := E4*N1;
-           CROW := Y*W;
-       end;
-(*
-        ROTATE THIS ROW INTO THE BAND TRIANGULAR SYSTEM USING PLANE
-        ROTATIONS.
-*)
-       for lplus1:=1 to 4 do
-       begin L := LPLUS1 - 1;
-          RELEMT := WORK1^[LPLUS1];
-          if relemt<>0 then
-          begin JPLUSL := J + L;
-            D := WORK2^[JPLUSL,1];
-            IF (ABS(RELEMT)>=D)
-            then DPRIME := ABS(RELEMT)*SQRT(1+sqr(D/RELEMT))
-            else DPRIME := D*SQRT(1+sqr(RELEMT/D));
-            WORK2^[JPLUSL,1] := DPRIME;
-            COSINE := D/DPRIME; SINE := RELEMT/DPRIME;
-            for iu :=2 to 4-l do
-            begin
-               LPLUSU := L + IU;
-               ACOL := WORK2^[JPLUSL,iu];
-               AROW := WORK1^[LPLUSU];
-               WORK2^[JPLUSL,iu] := COSINE*ACOL + SINE*AROW;
-               WORK1^[LPLUSU] := COSINE*AROW - SINE*ACOL
-            end;
-
-            CCOL := C[JPLUSL];
-            C[JPLUSL] := COSINE*CCOL + SINE*CROW;
-            CROW := COSINE*CROW - SINE*CCOL
-          end;
-       end;
-       SIGMA := SIGMA + sqr(CROW)
-   end;
-
-   residu := SIGMA;
-(*
-     SOLVE THE BAND TRIANGULAR SYSTEM FOR THE B-SPLINE
-     COEFFICIENTS. IF A DIAGONAL ELEMENT IS ZERO, AND HENCE
-     THE TRIANGULAR SYSTEM IS SINGULAR, THE IMPLICATION IS
-     THAT THE SCHOENBERG-WHITNEY CONDITIONS ARE ONLY JUST
-     SATISFIED. THUS IT IS APPROPRIATE TO EXIT IN THIS
-     CASE WITH THE SAME VALUE  (IFAIL=5)  OF THE ERROR
-     INDICATOR.
-*)
-    term := 2;
-    L := -1;
-    for jrev:=1 to q do
-    begin
-       J := q - JREV + 1; D := WORK2^[J,1];
-       if d=0 then goto einde;
-       IF l<3 then L := L + 1;
-       S := C[j];
-       for i:=1 to l do
-       begin
-         IPLUSJ := I + J;
-         S := S - WORK2^[j,i+1]*C[IPLUSJ];
-       end;
-       C[J] := S/D
-    end;
-
-    term:=1;
-einde:
-    FreeMem(Work2, q*4*SizeOf(ArbFloat));
-    FreeMem(Work1, m*SizeOf(ArbFloat))
-
-end;
-
-procedure spl2bspf(M, Qx, Qy: ArbInt; var XYZW1: ArbFloat;
-                 var Kxmin1, Kymin1, C11, residu: ArbFloat;
-                 var term: ArbInt);
-
-(* !!!!!!!! Test input !!!!!!!!!! *)
-
-(*
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c part 1: determination of the number of knots and their position.     c
-c ****************************************************************     c
-c given a set of knots we compute the least-squares spline sinf(x,y),  c
-c and the corresponding weighted sum of squared residuals fp=f(p=inf). c
-c if iopt=-1  sinf(x,y) is the requested approximation.                c
-c if iopt=0 or iopt=1 we check whether we can accept the knots:        c
-c   if fp <=s we will continue with the current set of knots.          c
-c   if fp > s we will increase the number of knots and compute the     c
-c      corresponding least-squares spline until finally  fp<=s.        c
-c the initial choice of knots depends on the value of s and iopt.      c
-c   if iopt=0 we first compute the least-squares polynomial of degree  c
-c     3 in x and 3 in y; nx=nminx=2*3+2 and ny=nminy=2*3+2.            c
-c     fp0=f(0) denotes the corresponding weighted sum of squared       c
-c     residuals                                                        c
-c   if iopt=1 we start with the knots found at the last call of the    c
-c     routine, except for the case that s>=fp0; then we can compute    c
-c     the least-squares polynomial directly.                           c
-c eventually the independent variables x and y (and the corresponding  c
-c parameters) will be switched if this can reduce the bandwidth of the c
-c system to be solved.                                                 c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc *)
-
-function Min(a, b:ArbInt): ArbInt;
-begin if a<b then Min := a else Min := b end;
-
-procedure WisselR(var x, y: ArbFloat);
-var h: ArbFloat; begin h := x; x := y; y := h end;
-
-procedure Wisseli(var x, y: ArbInt);
-var h: ArbInt; begin h := x; x := y; y := h end;
-
-procedure fprota(var cos1, sin1, a, b: ArbFloat);
-var store: ArbFloat;
-begin
-    store := b; b := cos1*b+sin1*a; a := cos1*a-sin1*store
-end;
-
-procedure fpgivs(var piv, ww, cos1, sin1: ArbFloat);
-var store, dd: ArbFloat;
-begin
-   store := abs(piv);
-   if store>=ww
-   then dd := store*sqrt(1+sqr(ww/piv))
-   else dd := ww*sqrt(1+sqr(piv/ww));
-   cos1 := ww/dd; sin1 := piv/dd; ww := dd
-end;
-
-procedure fpback(var a11, z1: ArbFloat; n, k: ArbInt; var c1: ArbFloat);
-(*
-   subroutine fpback calculates the solution of the system of
-   equations a*c = z with a a n x n upper triangular matrix
-   of bandwidth k.
-   ArbFloat a(.,k)
-*)
-var a: arfloat1 absolute a11;
-    z: arfloat1 absolute z1;
-    c: arfloat1 absolute c1;
-    i, l: ArbInt;
-    store : ArbFloat;
-begin
-    for i:=n downto 1 do
-    begin
-       store := z[i];
-       for l:=min(n+1-i,k)-1 downto 1 do store := store-c[i+l]*a[(i-1)*k+l+1];
-       c[i] := store/a[(i-1)*k+1]
-    end;
-end;
-
-procedure fpbspl(var kmin1: ArbFloat; x: ArbFloat; l: ArbInt; var h: r4);
-(*
-   subroutine fpbspl evaluates the 4 non-zero b-splines of
-   degree 3 at t(l) <= x < t(l+1) using the stable recurrence
-   relation of de boor and cox.
-*)
-var k : arfloat_1 absolute kmin1;
-    f : ArbFloat;
-    hh: array[1..3] of ArbFloat;
-    i, j, li, lj : ArbInt;
-begin
-    h[1] := 1;
-    for j:=1 to 3 do
-    begin
-       for i:=1 to j do hh[i] := h[i];
-       h[1] := 0;
-       for i:=1 to j do
-       begin
-          li := l+i; lj := li-j;
-          f := hh[i]/(k[li]-k[lj]);
-          h[i] := h[i]+f*(k[li]-x);
-          h[i+1] := f*(x-k[lj])
-       end;
-    end;
-end;
-
-procedure fporde(m, qx, qy: ArbInt; var xyzw1, kxmin1, kymin1: ArbFloat;
-                 var nummer1, index1: ArbInt);
-var xi, yi : ArbFloat;
-    i, im, num,
-    k, l   : ArbInt;
-    xyzw   : r4Ar absolute xyzw1;
-    kx     : arfloat_1 absolute kxmin1;
-    ky     : arfloat_1 absolute kymin1;
-    nummer : arint1 absolute nummer1;
-    index  : arint1 absolute index1;
-begin
-   for i:=1 to (qx-3)*(qy-3) do index[i] := 0;
-   for im:=1 to m do
-   with xyzw[im] do
-   begin
-     l := 2; while (x>=kx[l+1]) and (l<qx-2) do Inc(l);
-     k := 2; while (y>=ky[k+1]) and (k<qy-2) do Inc(k);
-     num := (l-2)*(qy-3)+k-1;
-     nummer[im] := index[num]; index[num] := im
-   end;
-end;
-
-label einde;
-
-var x0, x1, y0, y1, eps, cos1, sin1, dmax, sigma,
-    wi, zi, hxi, piv    : ArbFloat;
-    i, j, l, l1, l2, lx, ly, nreg, ncof, jrot,
-    inpanel, i1, j1,
-    iband, num, irot    : ArbInt;
-    xyzw                : r4Ar absolute xyzw1;
-    kx, ky              : ^arfloat_1;
-    a, f, h             : ^arfloat1;
-    c                   : arfloat1 absolute c11;
-    nummer, index       : ^arint1;
-    hx, hy              : r4;
-    ichang, fullrank    : boolean;
-begin
-
-    eps := 10*macheps;
-(*  find the position of the additional knots which are needed for the
-  b-spline representation of s(x,y) *)
-    iband := 1+min(3*qy+3,3*qx+3);
-    if qy>qx then
-    begin
-       ichang := true;
-       kx := @kymin1; ky := @kxmin1;
-       for i:=1 to m do with xyzw[i] do Wisselr(x, y);
-       WisselI(qx, qy)
-    end else
-    begin
-       ichang := false;
-       kx := @kxmin1; ky := @kymin1;
-    end;
-    with xyzw[1] do begin x0 := x; x1 := x; y0 := y; y1 := y end;
-    for i:=2 to m do with xyzw[i] do
-    begin if x<x0 then x0 := x; if x>x1 then x1 := x;
-          if y<y0 then y0 := y; if y>y1 then y1 := y
-    end;
-    for i:=-1 to 2 do kx^[i] := x0;
-    for i:=-1 to 2 do ky^[i] := y0;
-    for i:=qx-1 to qx+2 do kx^[i] := x1;
-    for i:=qy-1 to qy+2 do ky^[i] := y1;
-(*  arrange the data points according to the panel they belong to *)
-    nreg := (qx-3)*(qy-3);
-    ncof := qx*qy;
-    GetMem(nummer, m*SizeOf(ArbInt));
-    GetMem(index, nreg*SizeOf(ArbInt));
-    GetMem(h, iband*SizeOf(ArbFloat));
-    GetMem(a, iband*ncof*SizeOf(ArbFloat));
-    GetMem(f, ncof*SizeOf(ArbFloat));
-    fporde(m, qx, qy, xyzw1, kx^[-1], ky^[-1], nummer^[1], index^[1]);
-    for i:=1 to ncof do f^[i] := 0;
-    for j:=1 to ncof*iband do a^[j] := 0;
-    residu := 0;
-(*  fetch the data points in the new order. main loop for the different panels *)
-    for num:=1 to nreg do
-    begin
-       lx := (num-1) div (qy-3); l1 := lx+2;
-       ly := (num-1) mod (qy-3); l2 := ly+2;
-       jrot := lx*qy+ly;
-       inpanel := index^[num];
-       while inpanel<>0 do
-       with xyzw[inpanel] do
-       begin
-          wi := w; zi := z*wi;
-          fpbspl(kx^[-1], x, l1, hx);
-          fpbspl(ky^[-1], y, l2, hy);
-          for i:=1 to iband do h^[i] := 0;
-          i1 := 0;
-          for i:=1 to 4 do
-          begin
-            hxi := hx[i]; j1 := i1;
-            for j:=1 to 4 do begin Inc(j1); h^[j1] := hxi*hy[j]*wi end;
-            Inc(i1, qy)
-          end;
-          irot := jrot;
-          for i:=1 to iband do
-          begin
-            Inc(irot); piv := h^[i];
-            if piv<>0 then
-            begin
-              fpgivs(piv, a^[(irot-1)*iband+1], cos1, sin1);
-              fprota(cos1, sin1, zi, f^[irot]);
-              for j:=i+1 to iband do
-                fprota(cos1, sin1, h^[j], a^[(irot-1)*iband+j-i+1])
-            end;
-          end;
-          residu := residu+sqr(zi);
-          inpanel := nummer^[inpanel]
-      end;
-   end;
-
-   dmax := 0;
-   i := 1;
-   while i<ncof*iband do
-   begin
-      if dmax<a^[i] then dmax:=a^[i]; Inc(i, iband)
-   end;
-
-   sigma := eps*dmax;
-   i := 1; fullrank := true;
-   while fullrank and (i<ncof*iband) do
-   begin
-      fullrank := a^[i]>sigma; Inc(i, iband)
-   end;
-
-   term := 2; if not fullrank then goto einde;
-   term := 1;
-
-   fpback(a^[1], f^[1], ncof, iband, c11);
-   if ichang then
-   begin
-      l1 := 1;
-      for i:=1 to qx do
-      begin
-        l2 := i;
-        for j:=1 to qy do
-        begin
-          f^[l2] := c[l1]; Inc(l1); Inc(l2, qx)
-        end;
-      end;
-      for i:=1 to ncof do c[i] := f^[i]
-   end;
-
-einde:
-   if ichang then for i:=1 to m do with xyzw[i] do Wisselr(x, y);
-   FreeMem(f, ncof*SizeOf(ArbFloat));
-   FreeMem(a, iband*ncof*SizeOf(ArbFloat));
-   FreeMem(h, iband*SizeOf(ArbFloat));
-   FreeMem(index, nreg*SizeOf(ArbInt));
-   FreeMem(nummer, m*SizeOf(ArbInt))
-end;
-
-
-procedure spl1nati(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
-var
-    xyc           : r3Ar absolute XYC1;
-    l, b, d, u, c : ^arfloat1;
-    h2, h3, s2, s3: ArbFloat;
-    i, m          : ArbInt;       { afmeting van op te lossen stelsel }
-begin
-    term:=3;
-    if n < 2 then exit;
-    for i:=2 to n do if xyc[i-1].x>=xyc[i].x then exit;
-    term:=1;
-    xyc[1].w := 0; xyc[n].w := 0;  { c1=cn=0 }
-    m := n-2;
-    if m=0 then exit;
-
-    getmem(u, n*SizeOf(ArbFloat));
-    getmem(l, n*Sizeof(ArbFloat));
-    getmem(d, n*SizeOf(ArbFloat));
-    getmem(c, n*SizeOf(ArbFloat));
-    getmem(b, n*SizeOf(ArbFloat));
-    h3:=xyc[2].x-xyc[1].x;
-    s3:=(xyc[2].y-xyc[1].y)/h3;
-
-    for i:=2 to n-1 do
-    begin
-      h2:=h3; h3:=xyc[i+1].x-xyc[i].x;
-      s2:=s3; s3:=(xyc[i+1].y-xyc[i].y)/h3;
-      l^[i]:=h2/6;
-      d^[i]:=(h2+h3)/3;
-      u^[i]:=h3/6;
-      b^[i]:=s3-s2
-    end;
-    sledtr(m, l^[3], d^[2], u^[2], b^[2], c^[2], term);
-    for i:=2 to n-1 do xyc[i].w := c^[i];
-    Freemem(b, n*SizeOf(ArbFloat));
-    Freemem(c, n*SizeOf(ArbFloat));
-    Freemem(d, n*SizeOf(ArbFloat));
-    Freemem(l, n*Sizeof(ArbFloat));
-    Freemem(u, n*SizeOf(ArbFloat));
-end; {spl1nati}
-
-procedure spl1naki(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
-var
-    xyc           : r3Ar absolute XYC1;
-    l, b, d, u, c : ^arfloat1;
-    h2, h3, s2, s3: ArbFloat;
-    i, m          : ArbInt;       { Dimensions of set lin eqs to solve}
-begin
-    term:=3;
-    if n < 4 then exit;
-    for i:=2 to n do if xyc[i-1].x>=xyc[i].x then exit;
-    term:=1;
-    m := n-2;
-    getmem(u, n*SizeOf(ArbFloat));
-    getmem(l, n*Sizeof(ArbFloat));
-    getmem(d, n*SizeOf(ArbFloat));
-    getmem(c, n*SizeOf(ArbFloat));
-    getmem(b, n*SizeOf(ArbFloat));
-    h3:=xyc[2].x-xyc[1].x;
-    s3:=(xyc[2].y-xyc[1].y)/h3;
-    for i:=2 to n-1 do
-    begin
-      h2:=h3; h3:=xyc[i+1].x-xyc[i].x;
-      s2:=s3; s3:=(xyc[i+1].y-xyc[i].y)/h3;
-      l^[i]:=h2/6;
-      d^[i]:=(h2+h3)/3;
-      u^[i]:=h3/6;
-      b^[i]:=s3-s2
-    end;
-    d^[n-1]:=d^[n-1]+h3/6*(1+h3/h2); l^[n-1]:=l^[n-1]-sqr(h3)/(6*h2);
-    h2:=xyc[2].x-xyc[1].x; h3:=xyc[3].x-xyc[2].x;
-    d^[2]:=d^[2]+h2/6*(1+h2/h3); u^[2]:=u^[2]-sqr(h2)/(6*h3);
-
-    sledtr(m, l^[3], d^[2], u^[2], b^[2], c^[2], term);
-    for i:=2 to n-1 do xyc[i].w := c^[i];
-    xyc[1].w := xyc[2].w + (h2/h3)*(xyc[2].w-xyc[3].w);
-    h2:=xyc[n-1].x-xyc[n-2].x; h3:=xyc[n].x-xyc[n-1].x;
-    xyc[n].w := xyc[n-1].w + (h3/h2)*(xyc[n-1].w-xyc[n-2].w);
-    Freemem(b, n*SizeOf(ArbFloat));
-    Freemem(c, n*SizeOf(ArbFloat));
-    Freemem(d, n*SizeOf(ArbFloat));
-    Freemem(l, n*Sizeof(ArbFloat));
-    Freemem(u, n*SizeOf(ArbFloat));
-end; {spl1naki}
-
-procedure spl1cmpi(n: ArbInt; var xyc1: ArbFloat; dy1, dyn: ArbFloat;
-                 var term: ArbInt);
-var
-    xyc           : r3Ar absolute XYC1;
-    l, b, d, u, c : ^arfloat1;
-    h2, h3, s2, s3: ArbFloat;
-    i             : ArbInt;     { Dimensions of set lin eqs to solve}
-begin
-    term:=3;
-    if n < 2 then exit;
-    for i:=2 to n do if xyc[i-1].x>=xyc[i].x then exit;
-    term:=1;
-    getmem(u, n*SizeOf(ArbFloat));
-    getmem(l, n*Sizeof(ArbFloat));
-    getmem(d, n*SizeOf(ArbFloat));
-    getmem(c, n*SizeOf(ArbFloat));
-    getmem(b, n*SizeOf(ArbFloat));
-    h3:=xyc[2].x-xyc[1].x;
-    s3:=(xyc[2].y-xyc[1].y)/h3;
-    d^[1] := h3/3; u^[1] := h3/6; b^[1] := -dy1+s3;
-    for i:=2 to n-1 do
-    begin
-      h2:=h3; h3:=xyc[i+1].x-xyc[i].x;
-      s2:=s3; s3:=(xyc[i+1].y-xyc[i].y)/h3;
-      l^[i]:=h2/6;
-      d^[i]:=(h2+h3)/3;
-      u^[i]:=h3/6;
-      b^[i]:=s3-s2
-    end;
-    d^[n] := h3/3; l^[n] := h3/6; b^[n] := dyn-s3;
-
-    sledtr(n, l^[2], d^[1], u^[1], b^[1], c^[1], term);
-    for i:=1 to n do xyc[i].w := c^[i];
-    Freemem(b, n*SizeOf(ArbFloat));
-    Freemem(c, n*SizeOf(ArbFloat));
-    Freemem(d, n*SizeOf(ArbFloat));
-    Freemem(l, n*Sizeof(ArbFloat));
-    Freemem(u, n*SizeOf(ArbFloat));
-end; {spl1cmpi}
-
-procedure spl1peri(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
-var
-    xyc           : r3Ar absolute XYC1;
-    l, b, d, u, c, k : ^arfloat1;
-    k2, kn1, dy1, cn,
-    h2, h3, s2, s3: ArbFloat;
-    i, m          : ArbInt;             { Dimensions of set lin eqs to solve}
-begin
-    term:=3;
-    if n < 2 then exit;
-    if xyc[1].y<>xyc[n].y then exit;
-    for i:=2 to n do if xyc[i-1].x>=xyc[i].x then exit;
-    term:=1;
-    m := n-2;
-    xyc[1].w := 0; xyc[n].w := 0;  { c1=cn=0 }
-    if m=0 then exit;
-    if m=1 then
-    begin
-       h2:=xyc[2].x-xyc[1].x;
-       s2:=(xyc[2].y-xyc[1].y)/h2;
-       h3:=xyc[3].x-xyc[2].x;
-       s3:=(xyc[3].y-xyc[2].y)/h3;
-       xyc[2].w := 6*(s3-s2)/(h2+h3);
-       xyc[3].w := -xyc[2].w;
-       xyc[1].w := xyc[3].w;
-       exit
-    end;
-
-    getmem(u, n*SizeOf(ArbFloat));
-    getmem(l, n*Sizeof(ArbFloat));
-    getmem(k, n*SizeOf(ArbFloat));
-    getmem(d, n*SizeOf(ArbFloat));
-    getmem(c, n*SizeOf(ArbFloat));
-    getmem(b, n*SizeOf(ArbFloat));
-    h3:=xyc[2].x-xyc[1].x;
-    s3:=(xyc[2].y-xyc[1].y)/h3;
-    k2 := h3/6; dy1 := s3;
-    for i:=2 to n-1 do
-    begin
-      h2:=h3; h3:=xyc[i+1].x-xyc[i].x;
-      s2:=s3; s3:=(xyc[i+1].y-xyc[i].y)/h3;
-      l^[i]:=h2/6;
-      d^[i]:=(h2+h3)/3;
-      u^[i]:=h3/6;
-      b^[i]:=s3-s2;
-      k^[i]:=0
-    end;
-    kn1 := h3/6; k^[2] := k2; k^[n-1] := kn1;
-    sledtr(m, l^[3], d^[2], u^[2], k^[2], k^[2], term);
-    sledtr(m, l^[3], d^[2], u^[2], b^[2], c^[2], term);
-    cn := (dy1-s3-k2*c^[2]-kn1*c^[n-1])/(2*(k2+kn1)-k2*k^[2]-kn1*k^[n-1]);
-    for i:=2 to n-1 do xyc[i].w := c^[i] - cn*k^[i];
-    xyc[1].w := cn; xyc[n].w := cn;
-    Freemem(b, n*SizeOf(ArbFloat));
-    Freemem(c, n*SizeOf(ArbFloat));
-    Freemem(d, n*SizeOf(ArbFloat));
-    Freemem(l, n*Sizeof(ArbFloat));
-    Freemem(k, n*SizeOf(ArbFloat));
-    Freemem(u, n*SizeOf(ArbFloat));
-end; {spl1peri}
-
-function spl1pprv(n: ArbInt; var xyc1: ArbFloat; t: ArbFloat; var term: ArbInt): ArbFloat;
-var
-   xyc          : r3Ar absolute XYC1;
-   i, j, m      : ArbInt;
-   d, d3, h, dy : ArbFloat;
-begin                          { Assumption : x[i]<x[i+1] i=1..n-1 }
-  spl1pprv := NaN;
-  term:=3; if n<2 then exit;
-  if (t<xyc[1].x) or (t>xyc[n].x) then exit;
-  term:=1;
-  i:=1; j:=n;
-  while j <> i+1 do
-  begin
-      m:=(i+j) div 2;
-      if t>=xyc[m].x then i:=m else j:=m
-  end;   { x[i]<= t <=x[i+1] }
-  h     := xyc[i+1].x-xyc[i].x;
-  d     := t-xyc[i].x;
-  d3    :=(xyc[i+1].w-xyc[i].w)/h;
-  dy    :=(xyc[i+1].y-xyc[i].y)/h-h*(2*xyc[i].w+xyc[i+1].w)/6;
-  spl1pprv:= xyc[i].y+d*(dy+d*(xyc[i].w/2+d*d3/6))
-
-end; {spl1pprv}
-
-procedure spl1nalf(n: ArbInt; var xyw1: ArbFloat; lambda:ArbFloat;
-                     var xac1, residu: ArbFloat; var term: ArbInt);
-var
-   xyw        : r3Ar absolute xyw1;
-   xac        : r3Ar absolute xac1;
-   i, j, ncd  : ArbInt;
-   ca, crow   : ArbFloat;
-   h, qty     : ^arfloat1;
-   ch         : ^arfloat0;
-   qtdq       : ^arfloat1;
-begin
-   term := 3;                   { testing input}
-   if n<2 then exit;
-   for i:=2 to n do if xyw[i-1].x>=xyw[i].x then exit;
-   for i:=1 to n do if xyw[i].w<=0 then exit;
-   if lambda<0 then exit;
-   term := 1;
-   Move(xyw, xac, n*SizeOf(r_3));
-   if n=2 then begin xac[1].w := 0; xac[2].w := 0; exit end;
-
-   Getmem(ch, (n+2)*SizeOf(ArbFloat)); FillChar(ch^, (n+2)*SizeOf(ArbFloat), 0);
-   Getmem(h, n*SizeOf(ArbFloat));
-   Getmem(qty, n*SizeOf(ArbFloat));
-   ncd := n-3; if ncd>2 then ncd := 2;
-   Getmem(qtdq, ((n-2)*(ncd+1)-(ncd*(ncd+1)) div 2)*SizeOf(ArbFloat));
-   for i:=2 to n do h^[i] := 1/(xyw[i].x-xyw[i-1].x); h^[1] := 0;
-   for i:=1 to n-2
-   do qty^[i] := (h^[i+1]*xyw[i].y -
-                  (h^[i+1]+h^[i+2])*xyw[i+1].y +
-                  h^[i+2]*xyw[i+2].y);
-   j := 1; i := 1;
-   qtdq^[j] := sqr(h^[i+1])/xyw[i].w +
-               sqr(h^[i+1]+h^[i+2])/xyw[i+1].w +
-               sqr(h^[i+2])/xyw[i+2].w +
-               lambda*(1/h^[i+1]+1/h^[i+2])/3;
-   Inc(j);
-   if ncd>0 then
-   begin i := 2;
-      qtdq^[j] := -h^[i+1]*(h^[i]+h^[i+1])/xyw[i].w
-                  -h^[i+1]*(h^[i+1]+h^[i+2])/xyw[i+1].w +
-                   lambda/h^[i+1]/6;
-      Inc(j);
-      qtdq^[j] := sqr(h^[i+1])/xyw[i].w +
-                  sqr(h^[i+1]+h^[i+2])/xyw[i+1].w +
-                  sqr(h^[i+2])/xyw[i+2].w +
-                  lambda*(1/h^[i+1]+1/h^[i+2])/3;
-      Inc(j)
-   end;
-   for i:=3 to n-2
-   do begin
-      qtdq^[j] := h^[i]*h^[i+1]/xyw[i].w;
-      Inc(j);
-      qtdq^[j] := -h^[i+1]*(h^[i]+h^[i+1])/xyw[i].w
-                  -h^[i+1]*(h^[i+1]+h^[i+2])/xyw[i+1].w +
-                   lambda/h^[i+1]/6;
-      Inc(j);
-      qtdq^[j] := sqr(h^[i+1])/xyw[i].w +
-                  sqr(h^[i+1]+h^[i+2])/xyw[i+1].w +
-                  sqr(h^[i+2])/xyw[i+2].w +
-                  lambda*(1/h^[i+1]+1/h^[i+2])/3;
-      Inc(j)
-   end;
-   { Solving for c/lambda }
-   Slegpb(n-2, ncd, qtdq^[1], qty^[1], ch^[2], ca, term);
-   if term=1 then
-   begin
-       residu := 0;
-       for i:=1 to n do
-       begin
-         crow := (h^[i]*ch^[i-1] - (h^[i]+h^[i+1])*ch^[i]+h^[i+1]*ch^[i+1])
-                 /xyw[i].w;
-         xac[i].y := xyw[i].y - crow;
-         residu := residu + sqr(crow)*xyw[i].w
-       end;
-       xac[1].w := 0;
-       for i:=2 to n-1 do xac[i].w := lambda*ch^[i];
-       xac[n].w := 0;
-   end;
-   Freemem(qtdq, ((n-2)*(ncd+1)-(ncd*(ncd+1)) div 2)*SizeOf(ArbFloat));
-   Freemem(qty, n*SizeOf(ArbFloat));
-   Freemem(h, n*SizeOf(ArbFloat));
-   Freemem(ch, (n+2)*SizeOf(ArbFloat));
-end;
-
-
-procedure spl2nalf(n: ArbInt; var xyzw1: ArbFloat; lambda:ArbFloat;
-                   var xyg0, residu: ArbFloat; var term: ArbInt);
-type  R3 = array[1..3] of ArbFloat;
-      R33= array[1..3] of R3;
-      Rn3= array[1..$ffe0 div SizeOf(R3)] of R3;
-
-var b,e21t,ht   :^Rn3;
-    pfac        :par2dr1;
-    e22         :R33;
-    i,j,l,i1,i2,n3 :ArbInt;
-    s,s1,px,py,hr,ca,
-    x,absdet,x1,x2,
-    absdetmax   :ArbFloat;
-    vr          :R4x;
-    wr          :R2;
-    w,u         :R3;
-    a_alfa_d    :R4xAr absolute xyzw1;
-    a_gamma     :nsp2rec absolute xyg0;
-    gamma       :^arfloat1;
-
-
-  function e(var x,y:R2):ArbFloat;
-  const c1:ArbFloat=1/(16*pi);
-    var s:ArbFloat;
-    begin s:=sqr(x[1]-y[1]) +sqr(x[2]-y[2]);
-      if s=0 then e:=0 else e:=c1*s*ln(s)
-    end {e};
-
-   procedure pfxpfy(var a,b,c:R2;var f:r3; var pfx,pfy:ArbFloat);
-    var det:ArbFloat;
-    begin det:=(b[1]-a[1])*(c[2]-a[2]) - (b[2]-a[2])*(c[1]-a[1]);
-      pfx:=((f[2]-f[1])*(c[2]-a[2]) - (f[3]-f[1])*(b[2]-a[2]))/det;
-      pfy:=(-(f[2]-f[1])*(c[1]-a[1]) + (f[3]-f[1])*(b[1]-a[1]))/det
-    end {pfxpfy};
-
-  procedure pxpy(var a,b,c:R2; var px,py:ArbFloat);
-    var det : ArbFloat;
-    begin det:=(b[1]-a[1])*(c[2]-a[2]) - (b[2]-a[2])*(c[1]-a[1]);
-      px:=(b[2]-c[2])/det; py:=(c[1]-b[1])/det
-    end {pxpy};
-
-  function p(var x,a:R2; var px,py:ArbFloat):ArbFloat;
-    begin p:=1 + (x[1]-a[1])*px +(x[2]-a[2])*py end {p};
-
-  procedure slegpdlown(n: ArbInt; var a1; var bx1: ArbFloat;
-                    var term: ArbInt);
-   var i, j, k, kmin1 : ArbInt;
-       h, lkk : ArbFloat;
-       a  : ar2dr1 absolute a1;
-       x  : arfloat1 absolute bx1;
-   begin
-     k:=0; term := 2;
-     while (k<n) do
-       begin
-         kmin1:=k; k:=k+1; lkk:=a[k]^[k];
-         for j:=1 to kmin1 do lkk:=lkk-sqr(a[k]^[j]);
-         if lkk<=0 then exit else
-           begin
-             a[k]^[k]:=sqrt(lkk); lkk:=a[k]^[k];
-             for i:=k+1 to n do
-               begin
-                 h:=a[i]^[k];
-                 for j:=1 to kmin1 do h:=h-a[k]^[j]*a[i]^[j];
-                 a[i]^[k]:=h/lkk
-               end; {i}
-             h:=x[k];
-             for j:=1 to kmin1 do h:=h-a[k]^[j]*x[j];
-             x[k]:=h/lkk
-           end {lkk > 0}
-       end; {k}
-           for i:=n downto 1 do
-             begin
-               h:=x[i];
-               for j:=i+1 to n do h:=h-a[j]^[i]*x[j];
-               x[i]:=h/a[i]^[i];
-             end; {i}
-      term := 1
-   end;
-
-begin
-    term := 3; if n<3 then exit;
-    n3 := n - 3;
-    i1:=1; x1:=a_alfa_d[1].xy[1]; i2:=1; x2:=x1;
-    for i:= 2 to n do
-    begin hr:=a_alfa_d[i].xy[1];
-      if hr < x1 then begin i1:=i; x1:=hr end else
-      if hr > x2 then begin i2:=i; x2:=hr end;
-    end;
-    vr:=a_alfa_d[n-2]; a_alfa_d[n-2]:=a_alfa_d[i1]; a_alfa_d[i1]:=vr;
-    vr:=a_alfa_d[n-1]; a_alfa_d[n-1]:=a_alfa_d[i2]; a_alfa_d[i2]:=vr;
-
-    for i:=1 to 2 do vr.xy[i]:=a_alfa_d[n-2].xy[i]-a_alfa_d[n-1].xy[i];
-    absdetmax:=-1; i1:=0;
-    for i:=1 to n do
-    begin for j:=1 to 2 do wr[j]:=a_alfa_d[i].xy[j]-a_alfa_d[n-2].xy[j];
-      if a_alfa_d[i].d<=0 then exit;
-      absdet:=abs(wr[1]*vr.xy[2]-wr[2]*vr.xy[1]);
-      if absdet > absdetmax then begin i1:=i; absdetmax:=absdet end;
-    end;
-    term := 4;
-    if absdetmax<=macheps*abs(x2-x1) then exit;
-    term := 1;
-    vr:=a_alfa_d[n]; a_alfa_d[n]:=a_alfa_d[i1]; a_alfa_d[i1]:=vr;
-    GetMem(e21t, n3*SizeOf(r3));
-    GetMem(b, n3*SizeOf(r3));
-    GetMem(gamma, n*SizeOf(ArbFloat));
-
-    pxpy(a_alfa_d[n-2].xy,a_alfa_d[n-1].xy,a_alfa_d[n].xy,px,py);
-    for i:=1 to n3 do b^[i][1]:=p(a_alfa_d[i].xy,a_alfa_d[n-2].xy,px,py);
-    pxpy(a_alfa_d[n-1].xy,a_alfa_d[n].xy,a_alfa_d[n-2].xy,px,py);
-    for i:=1 to n3 do b^[i][2]:=p(a_alfa_d[i].xy,a_alfa_d[n-1].xy,px,py);
-    pxpy(a_alfa_d[n].xy,a_alfa_d[n-2].xy,a_alfa_d[n-1].xy,px,py);
-    for i:=1 to n3 do b^[i][3]:=p(a_alfa_d[i].xy,a_alfa_d[n].xy,px,py);
-    e22[1,1]:=0; e22[2,2]:=0; e22[3,3]:=0;
-    e22[2,1]:=e(a_alfa_d[n-1].xy,a_alfa_d[n-2].xy); e22[1,2]:=e22[2,1];
-    e22[3,1]:=e(a_alfa_d[n].xy,a_alfa_d[n-2].xy); e22[1,3]:=e22[3,1];
-    e22[3,2]:=e(a_alfa_d[n].xy,a_alfa_d[n-1].xy); e22[2,3]:=e22[3,2];
-    for i:=1 to 3 do
-    for j:=1 to n3 do e21t^[j,i]:=e(a_alfa_d[n3+i].xy,a_alfa_d[j].xy);
-
-    GetMem(ht, n3*SizeOf(r3));
-    for i:=1 to 3 do
-    for j:=1 to n3 do
-    begin s:=0;
-      for l:= 1 to 3 do s:=s+e22[i,l]*b^[j][l]; ht^[j][i]:=s
-    end;
-    AllocateL2dr(n3,pfac);
-    for i:= 1 to n3 do
-    for j:= 1 to i do
-    begin if j=i then s1:=0 else s1:=e(a_alfa_d[i].xy,a_alfa_d[j].xy);
-      for l:= 1 to 3 do s1:=s1+b^[i][l]*(ht^[j][l]-e21t^[j][l])-e21t^[i][l]*b^[j][l];
-      if j=i then s:=1/a_alfa_d[i].d else s:=0;
-      for l:= 1 to 3 do s:=s+b^[i][l]*b^[j][l]/a_alfa_d[n3+l].d;
-      pfac^[i]^[j] := s1+s/lambda
-    end;
-    for i:= 1 to n3 do
-      gamma^[i]:=a_alfa_d[i].alfa-b^[i][1]*a_alfa_d[n-2].alfa-b^[i][2]*a_alfa_d[n-1].alfa-b^[i][3]*a_alfa_d[n].alfa;
-    slegpdlown(n3,pfac^[1],gamma^[1],term);
-    DeAllocateL2dr(n3,pfac);
-    FreeMem(ht, n3*SizeOf(r3));
-
-    if term=1 then
-     begin
-      for i:= 1 to 3 do
-      begin s:= 0;
-        for j:= 1 to n3 do
-         s:=s+b^[j][i]*gamma^[j]; w[i]:=s;
-        gamma^[n3+i]:=-w[i]
-     end;{w=btgamma}
-      for i:=1 to 3 do
-      begin s:=0;
-        for l:=1 to n3 do s:=s+e21t^[l][i]*gamma^[l];
-        s1:=0;
-        for l:=1 to 3 do s1:=s1+e22[i,l]*w[l];
-        u[i]:=a_alfa_d[n3+i].alfa+w[i]/(lambda*a_alfa_d[n3+i].d)+s1-s
-      end;
-      with a_gamma[0] do
-      pfxpfy(a_alfa_d[n-2].xy,a_alfa_d[n-1].xy,a_alfa_d[n].xy,u,xy[1],xy[2]);
-      residu:=0;for i:=1 to n3 do residu:=residu+sqr(gamma^[i])/a_alfa_d[i].d;
-      for i:= 1 to 3 do residu:=residu+sqr(w[i])/a_alfa_d[n3+i].d;
-      residu:=residu/sqr(lambda);
-      a_gamma[0].gamma := u[1];
-      for i:=1 to n do
-      begin
-       a_gamma[i].xy := a_alfa_d[i].xy;
-       a_gamma[i].gamma := gamma^[i]
-      end;
-    end;
-    FreeMem(gamma, n*SizeOf(ArbFloat));
-    FreeMem(b, n3*SizeOf(r3));
-    FreeMem(e21t, n3*SizeOf(r3))
-  end;
-
-function spl2natv(n: ArbInt; var xyg0: ArbFloat; u, v: ArbFloat): ArbFloat;
-
-const c1: ArbFloat=1/(16*pi);
-
-  var i         : ArbInt;
-      s         : ArbFloat;
-      a_gamma   : nsp2rec absolute xyg0;
-      z         : R2;
-
-  function e(var x,y:R2):ArbFloat;
-    var s:ArbFloat;
-    begin
-      s:=sqr(x[1]-y[1]) + sqr(x[2]-y[2]);
-      if s=0 then
-       e:= 0
-      else
-       e:=s*ln(s)
-    end {e};
-
-  function pf(var x,a:R2;fa,pfx,pfy:ArbFloat):ArbFloat;
-    begin
-     pf:=fa + (x[1]-a[1])*pfx + (x[2]-a[2])*pfy
-    end {pf};
-
-  begin
-    s:=0;
-    z[1] := u;
-    z[2] := v;
-    for i:=1 to n do
-     s:=s+a_gamma[i].gamma*e(z, a_gamma[i].xy);
-    with a_gamma[0] do
-     spl2natv :=s*c1+pf(z,a_gamma[n-2].xy, gamma, xy[1], xy[2])
-  end;
-
-begin
-
-end.
-{
-  $Log$
-  Revision 1.1.2.1  2002-01-16 14:57:46  florian
-  no message
-
-  Revision 1.1  2000/07/13 06:34:16  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:42  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-
-
-}

packages/numlib/timer.pas

@@ -1,117 +0,0 @@
-unit timer;
-
-{ NOT PORTED YET, BUT NOT USED BY OTHER LIBS/AND OR DLL AND MOST DEMOES}
-
-
-{$r-,s-}
-
-INTERFACE
-
-var
-  timeractive: boolean;
-  exacttime, mstime: longint;
-
-function timervalue: longint;          {Return time in 10 usec units}
-function mstimer: longint;             {Return time in ms}
-
-IMPLEMENTATION
-
-uses dos, crt;
-
-var
-  lowbyte, highbyte, ref: word;
-  timerid: integer;
-  saveint, exitsave: pointer;
-
-function inport(x: integer): byte;     {Read i/o port}
-  inline($5a/$eb/$00/$ec);
-
-{$F+}
-procedure clock(p: pointer); interrupt;
-{$F-}
-  {Interrupt service routine to update timer reference values}
-
-  const
-    incr = 5493;                       {Timer increment per interrupt}
-
-  begin
-    port[$43] := $00;                  {Latch timer 0}
-    lowbyte := inport($40);
-    highbyte := inport($40);
-    ref := (highbyte shl 8) + lowbyte; {Base for subsequent readings
-                                          within current clock interval}
-    exacttime := exacttime + incr;     {New 10 usec timer value}
-    mstime := mstime + 55;             {New ms timer value}
-    inline($9c/$ff/$1e/saveint);       {Chain to old interrupt}
-  end;
-
-function timervalue: longint;
-
-  {Get value of 10-usec timer}
-
-  var
-    dif, low, high: word;
-    t: longint;
-
-  begin
-    inline($fa);                         {Disable interrupts}
-    port[$43] := $00;                    {Latch timer}
-    low := inport($40);                  {Timer LSB}
-    high := inport($40);                 {MSB}
-    dif := ref - ((high shl 8) + low);   {Delta from last sync}
-    timervalue := exacttime + (longint(dif)*100 div 1193);
-    inline($fb);                         {Re-enable interrupts}
-  end;
-
-function mstimer: longint;
-
-  {Get value of millisecond timer}
-
-  var
-    dif, low, high: word;
-    t: longint;
-
-  begin
-    inline($fa);
-    port[$43] := $00;
-    low := inport($40);
-    high := inport($40);
-    inline($fb);
-    dif := ref - ((high shl 8) + low);
-    mstimer := mstime + (dif div 1193);
-  end;
-
-procedure inittimer;
-
-  begin
-    exacttime := 0;
-    mstime := 0;
-    if not timeractive then
-      begin
-        port[$43] := $34;   {Mode 2 - countdown
-                             (approx .84 microsecond ticks)}
-        port[$40] := $ff;   {Initialize timer value}
-        port[$40] := $ff;
-        getintvec(8, saveint);         {Save old interrupt address}
-        setintvec(8, @clock);          {Install new service routine}
-        timeractive := true;
-        delay(60);                     {Allow for first tick}
-      end;
-  end;
-
-{$f+} procedure myexit; {$f-}
-
-  {Assure timer interrupt restored before exit}
-
-  begin
-    if timeractive then
-      setintvec(8, saveint);
-    exitproc := exitsave;             {Restore TP exit chain}
-  end;
-
-begin  {unit initialization}
-  timeractive := false;
-  exitsave := exitproc;               {Insert exit routine}
-  exitproc := @myexit;
-  InitTimer
-end.

packages/numlib/tpnumlib.pas

@@ -1,168 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             Documentation by Michael van Canneyt ([email protected])
-
-    This "library" imports 119 procedures from the numlib units, and throws
-    them in a dll file. The dll file can be accessed via numlib.pas
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-library tpnumlib;
-
-uses  DET, TYP, DSL, EIG, INT, INV, IOM, MDT, ODE, OMV, ROO, SLE, SPE, SPL,IPF;
-
-exports
- detgen          index      1,
- detgsy          index      2,
- detgpd          index      3,
- detgba          index      4,
- detgpb          index      5,
- detgtr          index      6,
-
- dslgen          index      7,
- dslgtr          index      8,
- dslgsy          index      9,
- dslgpd          index     10,
- dslgba          index     11,
- dslgpb          index     12,
- dsldtr          index     13,
-
- eiggs1          index     14,
- eiggs2          index     15,
- eiggs3          index     16,
- eiggs4          index     17,
- eigts1          index     18,
- eigts2          index     19,
- eigts3          index     20,
- eigts4          index     21,
- eigbs1          index     22,
- eigbs2          index     23,
- eigbs3          index     24,
- eigbs4          index     25,
- eigge1          index     26,
- eigge3          index     27,
- eiggg1          index     28,
- eiggg2          index     29,
- eiggg3          index     30,
- eiggg4          index     31,
- eigsv1          index     32,
- eigsv3          index     33,
-
- int1fr          index     34,
-
- invgen          index     35,
- invgsy          index     36,
- invgpd          index     37,
-
- iomrev          index     38,
- iomrem          index     39,
- iomwrv          index     40,
- iomwrm          index     41,
-
- mdtgen          index     42,
- mdtgtr          index     43,
- mdtgsy          index     44,
- mdtgpd          index     45,
- mdtgba          index     46,
- mdtgpb          index     47,
- mdtdtr          index     48,
-
- odeiv1          index     49,
- odeiv2          index     50,
-
- omvinp          index     51,
- omvmmm          index     52,
- omvmmv          index     53,
- omvn1m          index     54,
- omvn1v          index     55,
- omvn2v          index     56,
- omvnfm          index     57,
- omvnmm          index     58,
- omvnmv          index     59,
- omvtrm          index     60,
-
- roobin          index     61,
- roof1r          index     62,
- roopol          index     63,
- rooqua          index     64,
- roofnr          index     65,
-
- sledtr          index     66,
- slegba          index     67,
- slegbal         index     68,
- slegen          index     69,
- slegenl         index     70,
- slegls          index     71,
- sleglsl         index     72,
- slegpb          index     73,
- slegpbl         index     74,
- slegpd          index     75,
- slegpdl         index     76,
- slegsy          index     77,
- slegsyl         index     78,
- slegtr          index     79,
-
- spebi0          index     80,
- spebi1          index     81,
- spebj0          index     82,
- spebj1          index     83,
- spebk0          index     84,
- spebk1          index     85,
- speby0          index     86,
- speby1          index     87,
- speent          index     88,
- speerf          index     89,
- speefc          index     90,
- spegam          index     91,
- spelga          index     92,
- spemax          index     93,
- spepol          index     94,
- spepow          index     95,
- spesgn          index     96,
- spears          index     97,
- spearc          index     98,
- spesih          index     99,
- specoh          index    100,
- spetah          index    101,
- speash          index    102,
- speach          index    103,
- speath          index    104,
-
- spl1bspv        index    105,
- spl2bspv        index    106,
- spl1bspf        index    107,
- spl2bspf        index    108,
- spl1nati        index    109,
- spl1naki        index    110,
- spl1cmpi        index    111,
- spl1peri        index    112,
- spl1pprv        index    113,
- spl1nalf        index    114,
- spl2natv        index    115,
- spl2nalf        index    116,
- dllversion      index    117,
-// int1fr          index    117,                {existed twice, now used for dllversion}
- exp             index    118,
- MachCnst        index    119,
- ipffsn          index    120,
- ipfisn          index    121,
- ipfspn          index    122,
- ipfpol          index    123,
- spline          index    124,
- splineparameters index   125;
-
-begin
-end.

packages/numlib/typ.pas

@@ -1,580 +0,0 @@
-{
-    $Id$
-    This file is part of the Numlib package.
-    Copyright (c) 1986-2000 by
-     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
-     Computational centre of the Eindhoven University of Technology
-
-    FPC port Code          by Marco van de Voort ([email protected])
-             documentation by Michael van Canneyt ([email protected])
-
-    This is the most basic unit from NumLib.
-    The most important items this unit defines are matrix types and machine
-    constants
-
-    See the file COPYING.FPC, included in this distribution,
-    for details about the copyright.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-
-{
-In the FPC revision, instead of picking a certain floating point type,
- a new type "ArbFloat" is defined, which is used as floating point type
- throughout the entire library. If you change the floating point type, you
- should only have to change ArbFloat, and the machineconstants belonging to
- the type you want.
- However for IEEE Double (64bit) and Extended(80bit) these constants are
- already defined, and autoselected by the library. (the library tests the
- size of the float type in bytes for 8 and 10 and picks the appropiate
- constants
-
-Also some stuff had to be added to get ipf running (vector object and
-complex.inp and scale methods)
- }
-
-unit typ;
-
-{$I DIRECT.INC}                 {Contains "global" compilerswitches which
-                                  are imported into every unit of the library }
-
-{$DEFINE ArbExtended}
-
-interface
-
-
-CONST numlib_version=2;         {used to detect version conflicts between
-                                  header unit and dll}
-      highestelement=20000;     {Maximal n x m dimensions of matrix.
-                                 +/- highestelement*SIZEOF(arbfloat) is
-                                  minimal size of matrix.}
-type {Definition of base types}
-{$IFDEF ArbExtended}
-      ArbFloat    = extended;
-{$ELSE}
-     ArbFloat    = double;
-{$ENDIF}
-     ArbInt      = LONGINT;
-
-     Float8Arb  =ARRAY[0..7] OF BYTE;
-     Float10Arb =ARRAY[0..9] OF BYTE;
-
-CONST {Some constants for the variables below, in binary formats.}
-{$IFNDEF ArbExtended}
-        {First for REAL/Double}
-    TC1 :  Float8Arb  = ($00,$00,$00,$00,$00,$00,$B0,$3C);
-    TC2 :  Float8Arb  = ($FF,$FF,$FF,$FF,$FF,$FF,$EF,$7F);
-    TC3 :  Float8Arb  = ($00,$00,$00,$00,$01,$00,$10,$00);
-    TC4 :  Float8Arb  = ($00,$00,$00,$00,$00,$00,$F0,$7F);
-    TC5 :  Float8Arb  = ($EF,$39,$FA,$FE,$42,$2E,$86,$40);
-    TC6 :  Float8Arb  = ($D6,$BC,$FA,$BC,$2B,$23,$86,$C0);
-    TC7 :  Float8Arb  = ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF);
-{$ENDIF}
-
-     {For Extended}
-{$IFDEF ArbExtended}
-    TC1 : Float10Arb = (0,0,$00,$00,$00,$00,0,128,192,63);         {Eps}
-    TC2 : Float10Arb = ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$D6,$FE,127);  {9.99188560553925115E+4931}
-    TC3 : Float10Arb = (1,0,0,0,0,0,0,0,0,0);                      {3.64519953188247460E-4951}
-    TC4 : Float10Arb = (0,0,0,0,0,0,0,$80,$FF,$7F);                {Inf}
-    TC5 : Float10Arb = (18,25,219,91,61,101,113,177,12,64);        {1.13563488668777920E+0004}
-    TC6 : Float10Arb = (108,115,3,170,182,56,27,178,12,192);       {-1.13988053843083006E+0004}
-    TC7 : Float10Arb = ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF);  {NaN}
-{$ENDIF}
-  { numdig  is the number of useful (safe) decimal places of an "ArbFloat"
-            for display.
-    minform is the number of decimal places shown by the rtls
-            write(x:ArbFloat)
-    maxform is the maximal number of decimal positions
-    }
-
-    numdig    = 25;
-    minform   = 10;
-    maxform   = 26;
-
-var
-    macheps  : ArbFloat absolute TC1;  { macheps = r - 1,  with r
-                                        the smallest ArbFloat > 1}
-    giant    : ArbFloat absolute TC2;  { the largest ArbFloat}
-    midget   : ArbFloat absolute TC3;  { the smallest positive ArbFloat}
-    infinity : ArbFloat absolute TC4;  { INF as defined in IEEE-754(double)
-                                         or intel (for extended)}
-    LnGiant  : ArbFloat absolute TC5;  {ln of giant}
-    LnMidget : ArbFloat absolute TC6;  {ln of midget}
-    NaN      : ArbFloat absolute TC7;  {Not A Number}
-
-{Copied from Det. Needs ArbExtended conditional}
-const               {  og = 8^-maxexp, ogý>=midget,
-                       bg = 8^maxexp,  bgý<=giant
-
-                       midget and giant are defined in typ.pas}
-
-{$IFDEF ArbExtended}
-    ogx: Float10Arb = (51,158,223,249,51,243,4,181,224,31);
-    bgx: Float10Arb = (108,119,117,92,70,38,155,234,254,95);
-    maxexpx : ArbInt = 2740;
-{$ELSE}
-    ogx: Float8Arb= (84, 254, 32, 128, 32, 0, 0, 32);
-    bgx: Float8Arb= (149, 255, 255, 255, 255, 255, 239, 95);
-    maxexpx : ArbInt = 170;
-{$ENDIF}
-
-  var
-    og          : ArbFloat absolute ogx;
-    bg          : ArbFloat absolute bgx;
-    MaxExp      : ArbInt   absolute maxexpx;
-
-
-{Like standard EXP(), but for very small values (near lowest possible
-      ArbFloat this version returns 0}
-Function exp(x: ArbFloat): ArbFloat;
-
-type
-     Complex  = object
-       { Crude complex record. For me an example of
-         useless OOP, specially if you have operator overloading
-       }
-                   xreal, imag : ArbFloat;
-                   procedure Init (r, i: ArbFloat);
-                   procedure Add  (c: complex);
-                   procedure Sub  (c: complex);
-                   function  Inp(z:complex):ArbFloat;
-                   procedure Conjugate;
-                   procedure Scale(s: ArbFloat);
-                   Function  Norm  : ArbFloat;
-                   Function  Size  : ArbFloat;
-                   Function  Re    : ArbFloat;
-                   procedure Unary;
-                   Function  Im    : ArbFloat;
-                   Function  Arg   : ArbFloat;
-                   procedure MinC(c: complex);
-                   procedure MaxC(c: complex);
-                   Procedure TransF(var t: complex);
-
-               end;
-
-    vector =  object
-               i, j, k: ArbFloat;
-               procedure Init (vii, vjj, vkk: ArbFloat);
-               procedure Unary;
-               procedure Add  (c: vector);
-               procedure Sub  (c: vector);
-               function  Vi : ArbFloat;
-               function  Vj : ArbFloat;
-               function  Vk : ArbFloat;
-               function  Norm  : ArbFloat;
-               Function  Norm8 : ArbFloat;
-               function  Size  : ArbFloat;
-               function  InProd(c: vector): ArbFloat;
-               procedure Uitprod(c: vector; var e: vector);
-               procedure Scale(s: ArbFloat);
-               procedure DScale(s: ArbFloat);
-               procedure Normalize;
-               procedure Rotate(calfa, salfa: ArbFloat; axe: vector);
-               procedure Show(p,q: ArbInt);
-            end;
-
-     transformorg  = record offset: complex; ss, sc: real end;
-     transform = record
-                       offsetx, offsety, scalex, scaley: ArbFloat
-                 end;
-
-
-
-     {Standard Functions used in NumLib}
-     rfunc1r    = Function(x : ArbFloat): ArbFloat;
-     rfunc2r    = Function(x, y : ArbFloat): ArbFloat;
-
-     {Complex version}
-     rfunc1z    = Function(z: complex): ArbFloat;
-
-     {Special Functions}
-     oderk1n    = procedure(x: ArbFloat; var y, f: ArbFloat);  
-     roofnrfunc = procedure(var x, fx: ArbFloat; var deff: boolean);
-
-     {Definition of matrix types in NumLib. First some vectors.
-      The high boundery is a maximal number only. Vectors can be smaller, but
-      not bigger. The difference is the starting number}
-     arfloat0   = array[0..highestelement] of ArbFloat;
-     arfloat1   = array[1..highestelement] of ArbFloat;
-     arfloat2   = array[2..highestelement] of ArbFloat;
-     arfloat_1  = array[-1..highestelement] of ArbFloat;
-
-     {A matrix is an array of floats}
-     ar2dr      = array[0..highestelement] of ^arfloat0;
-     ar2dr1     = array[1..highestelement] of ^arfloat1;
-
-     {Matrices can get big, so we mosttimes allocate them on the heap.}
-     par2dr1    = ^ar2dr1;
-
-     {Integer vectors}
-     arint0     = array[0..highestelement] of ArbInt;
-     arint1     = array[1..highestelement] of ArbInt;
-
-     {Boolean (true/false) vectors}
-     arbool1    = array[1..highestelement] of boolean;
-
-     {Complex vectors}
-     arcomp0    = array[0..highestelement] of complex;
-     arcomp1    = array[1..highestelement] of complex;
-     arvect0    = array[0..highestelement] of vector;
-     vectors    = array[1..highestelement] of vector;
-
-     parcomp    = ^arcomp1;
-
-{(de) Allocate mxn matrix to A}
-procedure AllocateAr2dr(m, n: integer; var a: par2dr1);   
-procedure DeAllocateAr2dr(m, n: integer; var a: par2dr1); 
-
-{(de) allocate below-left triangle matrix for (de)convolution
-(a 3x3 matrix looks like this
-
-  x
-  x x
-  x x x)
-}
-procedure AllocateL2dr(n: integer; var a: par2dr1);
-procedure DeAllocateL2dr(n: integer; var a: par2dr1);     
-
-{Get the Re and Im parts of a complex type}
-Function Re(z: complex): ArbFloat;                            
-Function Im(z: complex): ArbFloat;
-
-{ Creates a string from a floatingpoint value}
-Function R2S(x: ArbFloat; p, q: integer): string;             
-
-{Calculate inproduct of V1 and V2, which are vectors with N elements;
-I1 and I2 are the SIZEOF the datatypes of V1 and V2
-MvdV: Change this to "V1,V2:array of ArbFloat and forget the i1 and i2
-parameters?}
-
-Function Inprod(var V1, V2; n, i1, i2: ArbInt): ArbFloat;
-
-{Return certain special machine constants.(macheps=1, Nan=7)}
-Function MachCnst(n: ArbInt): ArbFloat;
-
-function dllversion:LONGINT;
-
-implementation
-
-Function MachCnst(n: ArbInt): ArbFloat;
-begin
-    case n of
-    1: MachCnst := macheps;
-    2: MachCnst := giant;
-    3: MachCnst := midget;
-    4: MachCnst := infinity;
-    5: MachCnst := LnGiant;
-    6: MachCnst := LnMidget;
-    7: MachCnst := Nan;
-    end
-end;
-
-{ Are used in many of the example programs}
-Function Re(z: complex): ArbFloat;
-begin
-  Re := z.xreal
-end;
-
-Function Im(z: complex): ArbFloat;
-begin
-  Im := z.imag
-end;
-
-{Kind of Sysutils.TrimRight and TrimLeft called after eachother}
-procedure Compress(var s: string);
-var i, j: LONGINT;
-begin
-     j := length(s);
-     while (j>0) and (s[j]=' ') do dec(j);
-     i := 1;
-     while (i<=j) and (s[i]=' ') do Inc(i);
-     s := copy(s, i, j+1-i)
-end;
-
-Function R2S(x: ArbFloat; p, q: integer): string;
-var s: string;
-    i, j, k: integer;
-begin
-   if q=-1 then
-    begin
-        Str(x:p, s);
-        i := Pos('E', s)-1; k := i+1;
-        j := i+3; while (j<length(s)) and (s[j]='0') do inc(j);
-        while s[i]='0' do dec(i); if s[i]='.' then dec(i);
-        if s[j]='0' then s := copy(s,1,i) else
-        if s[k]='-' then
-         s := copy(s, 1, i)+'E-'+Copy(s, j, length(s)+1-j)
-        else
-         s := copy(s, 1, i)+'E'+Copy(s, j, length(s)+1-j)
-    end
-   else
-    Str(x:p:q, s);
-   Compress(s);
-   R2S := s
-end;
-
-procedure AllocateAr2dr(m, n: integer; var a: par2dr1);
-var i: integer;
-begin
-    GetMem(a, m*SizeOf(pointer));
-    for i:=1 to m do GetMem(a^[i], n*SizeOf(ArbFloat))
-end;
-
-procedure DeAllocateAr2dr(m, n: integer; var a: par2dr1);
-var i: integer;
-begin
-    for i:=m downto 1 do FreeMem(a^[i], n*SizeOf(ArbFloat));
-    FreeMem(a, m*SizeOf(pointer));
-    a := Nil
-end;
-
-procedure AllocateL2dr(n: integer; var a: par2dr1);
-var i: integer;
-begin
-    GetMem(a, n*SizeOf(pointer));
-    for i:=1 to n do GetMem(a^[i], i*SizeOf(ArbFloat))
-end;
-
-procedure DeAllocateL2dr(n: integer; var a: par2dr1);
-var i: integer;
-begin
-    for i:=n downto 1 do FreeMem(a^[i], i*SizeOf(ArbFloat));
-    FreeMem(a, n*SizeOf(pointer));
-    a := Nil
-end;
-
-var h, r, i: ArbFloat;
-
-procedure Complex.Init(r, i: ArbFloat);
-begin
-      xreal:= r;
-      imag := i
-end;
-
-procedure Complex.Conjugate;
-begin
-    imag := -imag
-end;
-
-function Complex.Inp(z:complex):ArbFloat;
-begin
-     Inp := xreal*z.xreal + imag*z.imag
-end;
-
-procedure Complex.MinC(c: complex);
-begin if c.xreal<xreal then xreal := c.xreal;
-      if c.imag<imag then imag := c.imag
-end;
-
-procedure Complex.Maxc(c: complex);
-begin if c.xreal>xreal then xreal := c.xreal;
-      if c.imag>imag then imag := c.imag
-end;
-
-procedure Complex.Add(c: complex);
-begin
-    xreal := xreal + c.xreal; imag := imag + c.imag
-end;
-
-procedure Complex.Sub(c: complex);
-begin
-    xreal := xreal - c.xreal; imag := imag - c.imag
-end;
-
-Function Complex.Norm: ArbFloat;
-begin
-    Norm := Sqr(xreal) + Sqr(imag)
-end;
-
-Function Complex.Size: ArbFloat;
-begin
-    Size := Sqrt(Norm)
-end;
-
-Function Complex.Re: ArbFloat;
-begin
-    Re := xreal;
-end;
-
-Function Complex.Im: ArbFloat;
-begin
-    Im := imag
-end;
-
-Procedure Complex.TransF(var t: complex);
-var w: complex;
-    tt: transformorg absolute t;
-begin
-   w := Self; Conjugate;
-   with tt do
-    begin
-     w.scale(ss);
-     scale(sc);
-     Add(offset)
-    end;
-   Add(w)
-end;
-
-
-procedure Complex.Unary;
-begin
- xreal := -xreal;
- imag := -imag
-end;
-
-procedure Complex.Scale(s:ArbFloat);
-begin
-    xreal := xreal*s; imag := imag*s
-end;
-
-Function Complex.Arg: ArbFloat;
-begin
-    if xreal=0 then
-    if imag>0 then Arg := 0.5*pi else
-    if imag=0 then Arg := 0 else Arg := -0.5*pi else
-    if xReal>0 then Arg := ArcTan(imag/xReal)
-    else if imag>=0 then Arg := ArcTan(imag/xReal) + pi
-                    else Arg := ArcTan(imag/xReal) - pi
-end;
-
-Function exp(x: ArbFloat): ArbFloat;
-begin
-    if x<LnMidget then exp := 0 else exp := system.exp(x)
-end;
-
-{ procedure berekent: v1 = v1 + r*v2 i1 en i2 geven de
-  increments in bytes voor v1 en v2 }
-
-Function Inprod(var V1, V2; n, i1, i2: ArbInt): ArbFloat;
-
-VAR i: LONGINT;
-    p1, p2: ^ArbFloat;
-    s: ArbFloat;
-begin
-  IF I1 <>SIZEOF(ArbFloat) THEN
-   BEGIN
-    WRITELN('1 Something went probably wrong while porting!');
-    HALT;
-   END;
-   p1 := @v1; p2 := @v2; s := 0;
-   for i:=1 to n do
-    begin
-     s := s + p1^*p2^;
-     Inc(longint(p1), i1);
-     Inc(longint(p2), i2)
-    end;
-    Inprod := s
-end;
-
-procedure Vector.Init(vii, vjj, vkk: ArbFloat);
-begin
-    i := vii; j := vjj; k := vkk
-end;
-
-procedure Vector.Unary;
-begin i := -i; j := -j; k := -k end;
-
-procedure Vector.Add(c: vector);
-begin
-    i := i + c.i; j := j + c.j; k := k + c.k
-end;
-
-procedure Vector.Sub(c: vector);
-begin
-    i := i - c.i; j := j - c.j; k := k - c.k
-end;
-
-function Vector.Vi : ArbFloat; begin Vi := i end;
-
-function Vector.Vj : ArbFloat; begin Vj := j end;
-
-function Vector.Vk : ArbFloat; begin Vk := k end;
-
-function Vector.Norm:ArbFloat;
-begin
-    Norm := Sqr(i) + Sqr(j) + Sqr(k)
-end;
-
-function Vector.Norm8:ArbFloat;
-var r: ArbFloat;
-begin
-    r := abs(i);
-    if abs(j)>r then r := abs(j);
-    if abs(k)>r then r := abs(k);
-    Norm8 := r
-end;
-
-function Vector.Size: ArbFloat;
-begin
-    Size := Sqrt(Norm)
-end;
-
-function Vector.InProd(c: vector): ArbFloat;
-begin
-     InProd := i*c.i + j*c.j + k*c.k
-end;
-
-procedure Vector.Uitprod(c: vector; var e: vector);
-begin
-      e.i := j*c.k - k*c.j;
-      e.j := k*c.i - i*c.k;
-      e.k := i*c.j - j*c.i
-end;
-
-procedure Vector.Scale(s: ArbFloat);
-begin
-    i := i*s; j := j*s; k := k*s
-end;
-
-procedure Vector.DScale(s: ArbFloat);
-begin
-    i := i/s; j := j/s; k := k/s
-end;
-
-procedure Vector.Normalize;
-begin
-    DScale(Size)
-end;
-
-procedure Vector.Show(p,q:ArbInt);
-begin writeln(i:p:q, 'I', j:p:q, 'J', k:p:q, 'K') end;
-
-procedure Vector.Rotate(calfa, salfa: arbfloat; axe: vector);
-var qv : vector;
-begin
-    Uitprod(axe, qv); qv.scale(salfa);
-    axe.scale((1-calfa)*Inprod(axe));
-    scale(calfa); sub(qv);  add(axe)
-end;
-
-function dllversion:LONGINT;
-
-BEGIN
- dllversion:=numlib_version;
-END;
-
-
-END.
-
-{
-  $Log$
-  Revision 1.2.2.1  2002-01-16 14:57:47  florian
-  no message
-
-  Revision 1.2  2002/01/16 14:47:16  florian
-    + Makefile.fpc added
-    * several small changes to get things running with FPC 1.0.x
-
-  Revision 1.1  2000/07/13 06:34:16  michael
-  + Initial import
-
-  Revision 1.2  2000/01/25 20:21:41  marco
-   * small updates, crlf fix, and RTE 207 problem
-
-  Revision 1.1  2000/01/24 22:08:58  marco
-   * initial version
-}