From a686731c0aeb69f5c5a4624be2c6558a7cc83cdd Mon Sep 17 00:00:00 2001 From: "Timur A. Fatkhullin" Date: Fri, 30 Jan 2026 22:20:42 +0300 Subject: [PATCH] ... --- CMakeLists.txt | 192 +++++-- fitpack/CMakeLists.txt | 38 ++ fitpack/Makefile | 19 + fitpack/README | 3 + fitpack/bispeu.f | 66 +++ fitpack/bispev.f | 104 ++++ fitpack/clocur.f | 353 +++++++++++++ fitpack/cocosp.f | 181 +++++++ fitpack/concon.f | 234 +++++++++ fitpack/concur.f | 371 ++++++++++++++ fitpack/cualde.f | 92 ++++ fitpack/curev.f | 111 ++++ fitpack/curfit.f | 261 ++++++++++ fitpack/dblint.f | 91 ++++ fitpack/evapol.f | 84 +++ fitpack/fourco.f | 97 ++++ fitpack/fpader.f | 57 +++ fitpack/fpadno.f | 60 +++ fitpack/fpadpo.f | 71 +++ fitpack/fpback.f | 32 ++ fitpack/fpbacp.f | 59 +++ fitpack/fpbfout.f | 198 +++++++ fitpack/fpbisp.f | 81 +++ fitpack/fpbspl.f | 42 ++ fitpack/fpchec.f | 87 ++++ fitpack/fpched.f | 70 +++ fitpack/fpchep.f | 82 +++ fitpack/fpclos.f | 715 ++++++++++++++++++++++++++ fitpack/fpcoco.f | 169 ++++++ fitpack/fpcons.f | 443 ++++++++++++++++ fitpack/fpcosp.f | 363 +++++++++++++ fitpack/fpcsin.f | 57 +++ fitpack/fpcurf.f | 360 +++++++++++++ fitpack/fpcuro.f | 95 ++++ fitpack/fpcyt1.f | 54 ++ fitpack/fpcyt2.f | 33 ++ fitpack/fpdeno.f | 56 ++ fitpack/fpdisc.f | 44 ++ fitpack/fpfrno.f | 70 +++ fitpack/fpgivs.f | 21 + fitpack/fpgrdi.f | 601 ++++++++++++++++++++++ fitpack/fpgrpa.f | 314 ++++++++++++ fitpack/fpgrre.f | 329 ++++++++++++ fitpack/fpgrsp.f | 658 ++++++++++++++++++++++++ fitpack/fpinst.f | 78 +++ fitpack/fpintb.f | 131 +++++ fitpack/fpknot.f | 73 +++ fitpack/fpopdi.f | 182 +++++++ fitpack/fpopsp.f | 212 ++++++++ fitpack/fporde.f | 48 ++ fitpack/fppara.f | 402 +++++++++++++++ fitpack/fppasu.f | 393 ++++++++++++++ fitpack/fpperi.f | 617 ++++++++++++++++++++++ fitpack/fppocu.f | 73 +++ fitpack/fppogr.f | 411 +++++++++++++++ fitpack/fppola.f | 841 ++++++++++++++++++++++++++++++ fitpack/fprank.f | 237 +++++++++ fitpack/fprati.f | 31 ++ fitpack/fpregr.f | 368 +++++++++++++ fitpack/fprota.f | 14 + fitpack/fprppo.f | 62 +++ fitpack/fprpsp.f | 56 ++ fitpack/fpseno.f | 36 ++ fitpack/fpspgr.f | 440 ++++++++++++++++ fitpack/fpsphe.f | 765 +++++++++++++++++++++++++++ fitpack/fpsuev.f | 82 +++ fitpack/fpsurf.f | 681 ++++++++++++++++++++++++ fitpack/fpsysy.f | 57 +++ fitpack/fptrnp.f | 107 ++++ fitpack/fptrpe.f | 214 ++++++++ fitpack/insert.f | 103 ++++ fitpack/mcc_bsplines.h | 369 +++++++++++++ fitpack/parcur.f | 335 ++++++++++++ fitpack/parder.f | 180 +++++++ fitpack/pardeu.f | 159 ++++++ fitpack/pardtc.f | 157 ++++++ fitpack/parsur.f | 392 ++++++++++++++ fitpack/percur.f | 275 ++++++++++ fitpack/pogrid.f | 467 +++++++++++++++++ fitpack/polar.f | 451 ++++++++++++++++ fitpack/profil.f | 118 +++++ fitpack/regrid.f | 354 +++++++++++++ fitpack/spalde.f | 75 +++ fitpack/spgrid.f | 502 ++++++++++++++++++ fitpack/sphere.f | 405 +++++++++++++++ fitpack/splder.f | 193 +++++++ fitpack/splev.f | 139 +++++ fitpack/splint.f | 62 +++ fitpack/sproot.f | 186 +++++++ fitpack/surev.f | 107 ++++ fitpack/surfit.f | 414 +++++++++++++++ main.cpp | 9 +- mcc_angle.h | 718 ++++++++++++++++++++++++++ mcc_ccte_erfa.h | 895 ++++++++++++++++++++++++++++++++ mcc_ccte_iers.h | 501 ++++++++++++++++++ mcc_ccte_iers_default.h | 647 +++++++++++++++++++++++ mcc_concepts.h | 967 +++++++++++++++++++++++++++++++++++ mcc_constants.h | 35 ++ mcc_coordinate.h | 910 ++++++++++++++++++++++++++++++++ mcc_epoch.h | 412 +++++++++++++++ mcc_error.h | 124 +++++ mcc_pcm.h | 470 +++++++++++++++++ mcc_pzone.h | 455 ++++++++++++++++ mcc_pzone_container.h | 231 +++++++++ mcc_spdlog.h | 198 +++++++ mcc_telemetry.h | 369 +++++++++++++ mcc_traits.h | 248 +++++++++ mcc_utils.h | 750 +++++++++++++++++++++++++++ tests/mcc_coord_test.cpp | 86 ++++ tests/mcc_pzone_test.cpp | 70 +++ tests/mcc_telemetry_test.cpp | 90 ++++ 111 files changed, 27707 insertions(+), 50 deletions(-) create mode 100644 fitpack/CMakeLists.txt create mode 100644 fitpack/Makefile create mode 100644 fitpack/README create mode 100644 fitpack/bispeu.f create mode 100644 fitpack/bispev.f create mode 100644 fitpack/clocur.f create mode 100644 fitpack/cocosp.f create mode 100644 fitpack/concon.f create mode 100644 fitpack/concur.f create mode 100644 fitpack/cualde.f create mode 100644 fitpack/curev.f create mode 100644 fitpack/curfit.f create mode 100644 fitpack/dblint.f create mode 100644 fitpack/evapol.f create mode 100644 fitpack/fourco.f create mode 100644 fitpack/fpader.f create mode 100644 fitpack/fpadno.f create mode 100644 fitpack/fpadpo.f create mode 100644 fitpack/fpback.f create mode 100644 fitpack/fpbacp.f create mode 100644 fitpack/fpbfout.f create mode 100644 fitpack/fpbisp.f create mode 100644 fitpack/fpbspl.f create mode 100644 fitpack/fpchec.f create mode 100644 fitpack/fpched.f create mode 100644 fitpack/fpchep.f create mode 100644 fitpack/fpclos.f create mode 100644 fitpack/fpcoco.f create mode 100644 fitpack/fpcons.f create mode 100644 fitpack/fpcosp.f create mode 100644 fitpack/fpcsin.f create mode 100644 fitpack/fpcurf.f create mode 100644 fitpack/fpcuro.f create mode 100644 fitpack/fpcyt1.f create mode 100644 fitpack/fpcyt2.f create mode 100644 fitpack/fpdeno.f create mode 100644 fitpack/fpdisc.f create mode 100644 fitpack/fpfrno.f create mode 100644 fitpack/fpgivs.f create mode 100644 fitpack/fpgrdi.f create mode 100644 fitpack/fpgrpa.f create mode 100644 fitpack/fpgrre.f create mode 100644 fitpack/fpgrsp.f create mode 100644 fitpack/fpinst.f create mode 100644 fitpack/fpintb.f create mode 100644 fitpack/fpknot.f create mode 100644 fitpack/fpopdi.f create mode 100644 fitpack/fpopsp.f create mode 100644 fitpack/fporde.f create mode 100644 fitpack/fppara.f create mode 100644 fitpack/fppasu.f create mode 100644 fitpack/fpperi.f create mode 100644 fitpack/fppocu.f create mode 100644 fitpack/fppogr.f create mode 100644 fitpack/fppola.f create mode 100644 fitpack/fprank.f create mode 100644 fitpack/fprati.f create mode 100644 fitpack/fpregr.f create mode 100644 fitpack/fprota.f create mode 100644 fitpack/fprppo.f create mode 100644 fitpack/fprpsp.f create mode 100644 fitpack/fpseno.f create mode 100644 fitpack/fpspgr.f create mode 100644 fitpack/fpsphe.f create mode 100644 fitpack/fpsuev.f create mode 100644 fitpack/fpsurf.f create mode 100644 fitpack/fpsysy.f create mode 100644 fitpack/fptrnp.f create mode 100644 fitpack/fptrpe.f create mode 100644 fitpack/insert.f create mode 100644 fitpack/mcc_bsplines.h create mode 100644 fitpack/parcur.f create mode 100644 fitpack/parder.f create mode 100644 fitpack/pardeu.f create mode 100644 fitpack/pardtc.f create mode 100644 fitpack/parsur.f create mode 100644 fitpack/percur.f create mode 100644 fitpack/pogrid.f create mode 100644 fitpack/polar.f create mode 100644 fitpack/profil.f create mode 100644 fitpack/regrid.f create mode 100644 fitpack/spalde.f create mode 100644 fitpack/spgrid.f create mode 100644 fitpack/sphere.f create mode 100644 fitpack/splder.f create mode 100644 fitpack/splev.f create mode 100644 fitpack/splint.f create mode 100644 fitpack/sproot.f create mode 100644 fitpack/surev.f create mode 100644 fitpack/surfit.f create mode 100644 mcc_angle.h create mode 100644 mcc_ccte_erfa.h create mode 100644 mcc_ccte_iers.h create mode 100644 mcc_ccte_iers_default.h create mode 100644 mcc_constants.h create mode 100644 mcc_coordinate.h create mode 100644 mcc_error.h create mode 100644 mcc_pcm.h create mode 100644 mcc_pzone.h create mode 100644 mcc_pzone_container.h create mode 100644 mcc_spdlog.h create mode 100644 mcc_telemetry.h create mode 100644 mcc_traits.h create mode 100644 mcc_utils.h create mode 100644 tests/mcc_coord_test.cpp create mode 100644 tests/mcc_pzone_test.cpp create mode 100644 tests/mcc_telemetry_test.cpp diff --git a/CMakeLists.txt b/CMakeLists.txt index a678455..57c4e7e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -13,86 +13,184 @@ set(CMAKE_CXX_STANDARD_REQUIRED ON) set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/cmake") -find_package(Threads REQUIRED) -# ******* SPDLOG LIBRARY ******* +# ******* LIBRARY OPTIONS ******* + +option(USE_SPDLOG "Use of SPDLOG library (add implementation of logger class based on this library)" ON) +option(USE_ERFA "Use of ERFA library (add implementation of CCTE based on this library)" ON) +option(USE_BSPLINE_PCM "Use of FITPACK bivariate splines for PCM" ON) + + +option(BUILD_TESTS "Build tests" ON) + +find_package(Threads REQUIRED) include(FetchContent) include(ExternalProject) -set(SPDLOG_USE_STD_FORMAT ON CACHE INTERNAL "Use of C++20 std::format") -set(SPDLOG_FMT_EXTERNAL OFF CACHE INTERNAL "Turn off external fmt library") +# ******* SPDLOG LIBRARY ******* + +if (USE_SPDLOG) + set(SPDLOG_USE_STD_FORMAT ON CACHE INTERNAL "Use of C++20 std::format") + set(SPDLOG_FMT_EXTERNAL OFF CACHE INTERNAL "Turn off external fmt library") -find_package(spdlog CONFIG) -if (NOT ${spdlog_FOUND}) - FetchContent_Declare(spdlog - # ExternalProject_Add(spdlog - # SOURCE_DIR ${CMAKE_BINARY_DIR}/spdlog_lib - # BINARY_DIR ${CMAKE_BINARY_DIR}/spdlog_lib/build - GIT_REPOSITORY "https://github.com/gabime/spdlog.git" - GIT_TAG "v1.15.1" - GIT_SHALLOW TRUE - GIT_SUBMODULES "" - GIT_PROGRESS TRUE - CMAKE_ARGS "-DSPDLOG_USE_STD_FORMAT=ON -DSPDLOG_FMT_EXTERNAL=OFF" - # CONFIGURE_COMMAND "" - # BUILD_COMMAND "" - # INSTALL_COMMAND "" - # UPDATE_COMMAND "" - # SOURCE_SUBDIR cmake # turn off building - OVERRIDE_FIND_PACKAGE - ) find_package(spdlog CONFIG) + if (NOT ${spdlog_FOUND}) + FetchContent_Declare(spdlog + GIT_REPOSITORY "https://github.com/gabime/spdlog.git" + GIT_TAG "v1.15.1" + GIT_SHALLOW TRUE + GIT_SUBMODULES "" + GIT_PROGRESS TRUE + CMAKE_ARGS "-DSPDLOG_USE_STD_FORMAT=ON -DSPDLOG_FMT_EXTERNAL=OFF" + OVERRIDE_FIND_PACKAGE + ) + find_package(spdlog CONFIG) + endif() endif() # ******* ERFA LIBRARY ******* +find_program(MESON_PROG NAMES meson HINTS ENV PATHS) + +if (NOT MESON_PROG) + message(FATAL "meson executable can not be found!!!") +endif() + +find_program(NINJA_PROG NAMES ninja ninja-build) + +if (NOT NINJA_PROG) + message(FATAL "ninja executable can not be found!!!") +endif() + find_package(PkgConfig REQUIRED) pkg_check_modules(ERFALIB IMPORTED_TARGET GLOBAL erfa) if (NOT ERFALIB_FOUND) message(STATUS "\tfetch erfa-lib ...") - ExternalProject_Add(erfalib - PREFIX ${CMAKE_BINARY_DIR}/erfa_lib + # ExternalProject_Add(erfalib + # PREFIX ${CMAKE_BINARY_DIR}/erfa_lib + # GIT_REPOSITORY "https://github.com/liberfa/erfa.git" + # GIT_TAG "v2.0.1" + # UPDATE_COMMAND "" + # PATCH_COMMAND "" + # LOG_CONFIGURE 1 + # CONFIGURE_COMMAND meson setup --reconfigure -Ddefault_library=static -Dbuildtype=release + # -Dprefix=${CMAKE_BINARY_DIR}/erfa_lib -Dlibdir= -Dincludedir= -Ddatadir= + # BUILD_COMMAND ninja -C + # INSTALL_COMMAND meson install -C + # BUILD_BYPRODUCTS ${CMAKE_BINARY_DIR}/erfa_lib/liberfa.a + # ) + + # add_library(PkgConfig::ERFALIB STATIC IMPORTED GLOBAL) + # set_target_properties(PkgConfig::ERFALIB PROPERTIES IMPORTED_LOCATION ${CMAKE_BINARY_DIR}/erfa_lib/liberfa.a) + # set_target_properties(PkgConfig::ERFALIB PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${CMAKE_BINARY_DIR}/erfa_lib) + # add_dependencies(PkgConfig::ERFALIB erfalib) + + # set(CACHE{ERFALIB_INCLUDE_DIRS} TYPE PATH VALUE "${CMAKE_BINARY_DIR}/erfa_lib") + # set(CACHE{ERFALIB_LIBRARY_DIRS} TYPE PATH VALUE "${CMAKE_BINARY_DIR}/erfa_lib") + # set(CACHE{ERFALIB_LIBRARIES} TYPE STRING VALUE "erfa;m") + + + FetchContent_Declare(erfalib_project GIT_REPOSITORY "https://github.com/liberfa/erfa.git" GIT_TAG "v2.0.1" - UPDATE_COMMAND "" - PATCH_COMMAND "" - LOG_CONFIGURE 1 - CONFIGURE_COMMAND meson setup --reconfigure -Ddefault_library=static -Dbuildtype=release - -Dprefix=${CMAKE_BINARY_DIR}/erfa_lib -Dlibdir= -Dincludedir= -Ddatadir= - BUILD_COMMAND ninja -C - INSTALL_COMMAND meson install -C - BUILD_BYPRODUCTS ${CMAKE_BINARY_DIR}/erfa_lib/liberfa.a + GIT_SHALLOW TRUE + GIT_PROGRESS TRUE ) - add_library(PkgConfig::ERFALIB STATIC IMPORTED GLOBAL) - set_target_properties(PkgConfig::ERFALIB PROPERTIES IMPORTED_LOCATION ${CMAKE_BINARY_DIR}/erfa_lib/liberfa.a) - set_target_properties(PkgConfig::ERFALIB PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${CMAKE_BINARY_DIR}/erfa_lib) - add_dependencies(PkgConfig::ERFALIB erfalib) -#pkg_check_modules(ERFALIB REQUIRED IMPORTED_TARGET GLOBAL erfa) + FetchContent_MakeAvailable(erfalib_project) + # message(STATUS "ERFA: ${erfalib_project_SOURCE_DIR}") + message(STATUS "\tbuild erfa-lib ...") + execute_process( + COMMAND meson setup --reconfigure -Ddefault_library=static -Dbuildtype=release + -Dprefix=${CMAKE_BINARY_DIR}/erfa_lib -Dlibdir= -Dincludedir= -Ddatadir= ${CMAKE_BINARY_DIR}/erfa_lib ${erfalib_project_SOURCE_DIR} + ) + + execute_process( + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/erfa_lib + COMMAND ninja -C ${CMAKE_BINARY_DIR}/erfa_lib + ) + + execute_process( + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/erfa_lib + COMMAND meson install -C ${CMAKE_BINARY_DIR}/erfa_lib + ) + + set(ENV{PKG_CONFIG_PATH} "${CMAKE_BINARY_DIR}/erfa_lib/pkgconfig") + pkg_check_modules(ERFALIB IMPORTED_TARGET GLOBAL erfa) endif() -#message(STATUS "ERFA LIBS: ${ERFALIB_LIBRARIES}") -#message(STATUS "ERFA LIB PATHS: ${ERFALIB_LIBRARY_DIRS}") -#message(STATUS "ERFA INC PATHS: ${ERFALIB_INCLUDE_DIRS}") -#add_executable(ex main.cpp) -#target_link_libraries(ex PkgConfig::ERFALIB) -#target_link_libraries(ex ee) +message(STATUS "ERFA LIBS: ${ERFALIB_LIBRARIES}") +message(STATUS "ERFA LIB PATHS: ${ERFALIB_LIBRARY_DIRS}") +message(STATUS "ERFA INC PATHS: ${ERFALIB_INCLUDE_DIRS}") + + +if (USE_BSPLINE_PCM) + # fitpack by P. Dierckx + add_subdirectory(fitpack) +endif() + +set(MCC_SRC mcc_concepts.h mcc_constants.h mcc_epoch.h mcc_angle.h mcc_coordinate.h mcc_error.h + mcc_traits.h mcc_utils.h + mcc_ccte_iers.h mcc_ccte_iers_default.h mcc_ccte_erfa.h mcc_pzone.h mcc_pzone_container.h mcc_pcm.h mcc_telemetry.h) + +if (USE_SPDLOG) + list(APPEND MCC_SRC mcc_spdlog.h) +endif() -set(MCC_SRC mcc_concepts.h mcc_epoch.h) add_library(${PROJECT_NAME} INTERFACE ${MCC_SRC}) target_compile_features(${PROJECT_NAME} INTERFACE cxx_std_23) target_link_libraries(${PROJECT_NAME} INTERFACE PkgConfig::ERFALIB) +# target_link_libraries(${PROJECT_NAME} INTERFACE PkgConfig::ERFALIB fitpack) target_include_directories( ${PROJECT_NAME} INTERFACE - $ - $ + # $ + $ + $ ) +if (USE_BSPLINE_PCM) + target_compile_definitions(${PROJECT_NAME} INTERFACE USE_BSPLINE_PCM) + target_link_libraries(${PROJECT_NAME} INTERFACE fitpack) + # target_include_directories( + # ${PROJECT_NAME} + # INTERFACE + # $) +endif() + +# get_target_property(ZZ ${PROJECT_NAME} INTERFACE_INCLUDE_DIRECTORIES) + +# message(STATUS "INT: ${ZZ}") + + + +add_executable(exe EXCLUDE_FROM_ALL main.cpp) +target_link_libraries(exe PUBLIC ${PROJECT_NAME}) + +# get_target_property(ZZ exe INCLUDE_DIRECTORIES) + +# message(STATUS "INT: ${ZZ_STRING}") + + +if (BUILD_TESTS) + add_executable(mcc_telemetry_test tests/mcc_telemetry_test.cpp) + target_link_libraries(mcc_telemetry_test PRIVATE ${PROJECT_NAME}) + + add_executable(mcc_coord_test tests/mcc_coord_test.cpp) + target_link_libraries(mcc_coord_test PRIVATE ${PROJECT_NAME}) + + add_executable(mcc_pzone_test tests/mcc_pzone_test.cpp) + target_link_libraries(mcc_pzone_test PRIVATE ${PROJECT_NAME}) +else() + # This is just a stub to allow access to the path and library settings for the ${PROJECT_NAME} target during development + add_executable(just_stub EXCLUDE_FROM_ALL main.cpp) + target_link_libraries(just_stub PUBLIC ${PROJECT_NAME}) +endif() + include(CMakePackageConfigHelpers) write_basic_package_version_file("${PROJECT_NAME}ConfigVersion.cmake" diff --git a/fitpack/CMakeLists.txt b/fitpack/CMakeLists.txt new file mode 100644 index 0000000..7bcbd9d --- /dev/null +++ b/fitpack/CMakeLists.txt @@ -0,0 +1,38 @@ +cmake_minimum_required(VERSION 3.20) + +set(func_name "") + +file(GLOB src_files "*.f") + +foreach(ff IN LISTS src_files) + get_filename_component(sn ${ff} NAME_WE) + list(APPEND func_name ${sn}) +endforeach() + +# message(STATUS "${func_name}") + +string(REPLACE ";" " " func_str "${func_name}") + +# message(STATUS ${func_str}) + +enable_language(Fortran CXX) + +include(FortranCInterface) +FortranCInterface_HEADER(FortranCInterface.h + MACRO_NAMESPACE "FC_" + # SYMBOL_NAMESPACE "fp_" + SYMBOL_NAMESPACE "" + # SYMBOLS ${func_str} + SYMBOLS ${func_name} +) +FortranCInterface_VERIFY(CXX) + +# set(FITPACK_INCLUDE_DIR ${CMAKE_CURRENT_BINARY_DIR} PARENT_SCOPE) +# include_directories(${BSPLINES_INCLUDE_DIR}) + +add_library(fitpack_project STATIC EXCLUDE_FROM_ALL ${src_files} mcc_bsplines.h) + +add_library(fitpack STATIC IMPORTED GLOBAL) +set_target_properties(fitpack PROPERTIES IMPORTED_LOCATION ${CMAKE_BINARY_DIR}/fitpack/libfitpack_project.a) +set_target_properties(fitpack PROPERTIES INTERFACE_INCLUDE_DIRECTORIES "${CMAKE_CURRENT_SOURCE_DIR};${CMAKE_CURRENT_BINARY_DIR}") +add_dependencies(fitpack fitpack_project) diff --git a/fitpack/Makefile b/fitpack/Makefile new file mode 100644 index 0000000..a2242e8 --- /dev/null +++ b/fitpack/Makefile @@ -0,0 +1,19 @@ +# Makefile that builts a library lib$(LIB).a from all +# of the Fortran files found in the current directory. +# Usage: make LIB= +# Pearu + +OBJ=$(patsubst %.f,%.o,$(shell ls *.f)) +all: lib$(LIB).a +$(OBJ): + $(FC) -c $(FFLAGS) $(FSHARED) $(patsubst %.o,%.f,$(@F)) -o $@ +lib$(LIB).a: $(OBJ) + $(AR) rus lib$(LIB).a $? +clean: + rm *.o + + + + + + diff --git a/fitpack/README b/fitpack/README new file mode 100644 index 0000000..58924ce --- /dev/null +++ b/fitpack/README @@ -0,0 +1,3 @@ +- ddierckx is a 'real*8' version of dierckx + generated by Pearu Peterson . +- dierckx (in netlib) is fitpack by P. Dierckx diff --git a/fitpack/bispeu.f b/fitpack/bispeu.f new file mode 100644 index 0000000..90352ce --- /dev/null +++ b/fitpack/bispeu.f @@ -0,0 +1,66 @@ + recursive subroutine bispeu(tx,nx,ty,ny,c,kx,ky,x,y,z,m,wrk, + * lwrk, ier) + implicit none +c subroutine bispeu evaluates on a set of points (x(i),y(i)),i=1,...,m +c a bivariate spline s(x,y) of degrees kx and ky, given in the +c b-spline representation. +c +c calling sequence: +c call bispeu(tx,nx,ty,ny,c,kx,ky,x,y,z,m,wrk,lwrk, +c * iwrk,kwrk,ier) +c +c input parameters: +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c x : real array of dimension (mx). +c y : real array of dimension (my). +c m : on entry m must specify the number points. m >= 1. +c wrk : real array of dimension lwrk. used as workspace. +c lwrk : integer, specifying the dimension of wrk. +c lwrk >= kx+ky+2 +c +c output parameters: +c z : real array of dimension m. +c on successful exit z(i) contains the value of s(x,y) +c at the point (x(i),y(i)), i=1,...,m. +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c m >=1, lwrk>=mx*(kx+1)+my*(ky+1), kwrk>=mx+my +c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx +c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my +c +c other subroutines required: +c fpbisp,fpbspl +c +c ..scalar arguments.. + integer nx,ny,kx,ky,m,lwrk,ier +c ..array arguments.. + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(m),y(m),z(m), + * wrk(lwrk) +c ..local scalars.. + integer iwrk(2) + integer i, lwest +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + lwest = kx+ky+2 + if (lwrk.lt.lwest) go to 100 + if (m.lt.1) go to 100 + ier = 0 + do 10 i=1,m + call fpbisp(tx,nx,ty,ny,c,kx,ky,x(i),1,y(i),1,z(i),wrk(1), + * wrk(kx+2),iwrk(1),iwrk(2)) + 10 continue + 100 return + end diff --git a/fitpack/bispev.f b/fitpack/bispev.f new file mode 100644 index 0000000..aaebdb7 --- /dev/null +++ b/fitpack/bispev.f @@ -0,0 +1,104 @@ + recursive subroutine bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z, + * wrk,lwrk,iwrk,kwrk,ier) + implicit none +c subroutine bispev evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,... +c ,my a bivariate spline s(x,y) of degrees kx and ky, given in the +c b-spline representation. +c +c calling sequence: +c call bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk, +c * iwrk,kwrk,ier) +c +c input parameters: +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c x : real array of dimension (mx). +c before entry x(i) must be set to the x co-ordinate of the +c i-th grid point along the x-axis. +c tx(kx+1)<=x(i-1)<=x(i)<=tx(nx-kx), i=2,...,mx. +c mx : on entry mx must specify the number of grid points along +c the x-axis. mx >=1. +c y : real array of dimension (my). +c before entry y(j) must be set to the y co-ordinate of the +c j-th grid point along the y-axis. +c ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my. +c my : on entry my must specify the number of grid points along +c the y-axis. my >=1. +c wrk : real array of dimension lwrk. used as workspace. +c lwrk : integer, specifying the dimension of wrk. +c lwrk >= mx*(kx+1)+my*(ky+1) +c iwrk : integer array of dimension kwrk. used as workspace. +c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. +c +c output parameters: +c z : real array of dimension (mx*my). +c on successful exit z(my*(i-1)+j) contains the value of s(x,y) +c at the point (x(i),y(j)),i=1,...,mx;j=1,...,my. +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c mx >=1, my >=1, lwrk>=mx*(kx+1)+my*(ky+1), kwrk>=mx+my +c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx +c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my +c +c other subroutines required: +c fpbisp,fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer nx,ny,kx,ky,mx,my,lwrk,kwrk,ier +c ..array arguments.. + integer iwrk(kwrk) + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my), + * wrk(lwrk) +c ..local scalars.. + integer i,iw,lwest +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + lwest = (kx+1)*mx+(ky+1)*my + if(lwrk.lt.lwest) go to 100 + if(kwrk.lt.(mx+my)) go to 100 + if (mx.lt.1) go to 100 + if (mx.eq.1) go to 30 + go to 10 + 10 do 20 i=2,mx + if(x(i).lt.x(i-1)) go to 100 + 20 continue + 30 if (my.lt.1) go to 100 + if (my.eq.1) go to 60 + go to 40 + 40 do 50 i=2,my + if(y(i).lt.y(i-1)) go to 100 + 50 continue + 60 ier = 0 + iw = mx*(kx+1)+1 + call fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk(1),wrk(iw), + * iwrk(1),iwrk(mx+1)) + 100 return + end diff --git a/fitpack/clocur.f b/fitpack/clocur.f new file mode 100644 index 0000000..88d7a22 --- /dev/null +++ b/fitpack/clocur.f @@ -0,0 +1,353 @@ + recursive subroutine clocur(iopt,ipar,idim,m,u,mx,x,w,k,s,nest, + * n,t,nc,c,fp,wrk,lwrk,iwrk,ier) + implicit none +c given the ordered set of m points x(i) in the idim-dimensional space +c with x(1)=x(m), and given also a corresponding set of strictly in- +c creasing values u(i) and the set of positive numbers w(i),i=1,2,...,m +c subroutine clocur determines a smooth approximating closed spline +c curve s(u), i.e. +c x1 = s1(u) +c x2 = s2(u) u(1) <= u <= u(m) +c ......... +c xidim = sidim(u) +c with sj(u),j=1,2,...,idim periodic spline functions of degree k with +c common knots t(j),j=1,2,...,n. +c if ipar=1 the values u(i),i=1,2,...,m must be supplied by the user. +c if ipar=0 these values are chosen automatically by clocur as +c v(1) = 0 +c v(i) = v(i-1) + dist(x(i),x(i-1)) ,i=2,3,...,m +c u(i) = v(i)/v(m) ,i=1,2,...,m +c if iopt=-1 clocur calculates the weighted least-squares closed spline +c curve according to a given set of knots. +c if iopt>=0 the number of knots of the splines sj(u) and the position +c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- +c ness of s(u) is then achieved by minimalizing the discontinuity +c jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,..., +c n-k-1. the amount of smoothness is determined by the condition that +c f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non- +c negative constant, called the smoothing factor. +c the fit s(u) is given in the b-spline representation and can be +c evaluated by means of subroutine curev. +c +c calling sequence: +c call clocur(iopt,ipar,idim,m,u,mx,x,w,k,s,nest,n,t,nc,c, +c * fp,wrk,lwrk,iwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a weighted +c least-squares closed spline curve (iopt=-1) or a smoothing +c closed spline curve (iopt=0 or 1) must be determined. if +c iopt=0 the routine will start with an initial set of knots +c t(i)=u(1)+(u(m)-u(1))*(i-k-1),i=1,2,...,2*k+2. if iopt=1 the +c routine will continue with the knots found at the last call. +c attention: a call with iopt=1 must always be immediately +c preceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c ipar : integer flag. on entry ipar must specify whether (ipar=1) +c the user will supply the parameter values u(i),or whether +c (ipar=0) these values are to be calculated by clocur. +c unchanged on exit. +c idim : integer. on entry idim must specify the dimension of the +c curve. 0 < idim < 11. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m > 1. unchanged on exit. +c u : real array of dimension at least (m). in case ipar=1,before +c entry, u(i) must be set to the i-th value of the parameter +c variable u for i=1,2,...,m. these values must then be +c supplied in strictly ascending order and will be unchanged +c on exit. in case ipar=0, on exit,the array will contain the +c values u(i) as determined by clocur. +c mx : integer. on entry mx must specify the actual dimension of +c the array x as declared in the calling (sub)program. mx must +c not be too small (see x). unchanged on exit. +c x : real array of dimension at least idim*m. +c before entry, x(idim*(i-1)+j) must contain the j-th coord- +c inate of the i-th data point for i=1,2,...,m and j=1,2,..., +c idim. since first and last data point must coincide it +c means that x(j)=x(idim*(m-1)+j),j=1,2,...,idim. +c unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) +c must be set to the i-th value in the set of weights. the +c w(i) must be strictly positive. w(m) is not used. +c unchanged on exit. see also further comments. +c k : integer. on entry k must specify the degree of the splines. +c 1<=k<=5. it is recommended to use cubic splines (k=3). +c the user is strongly dissuaded from choosing k even,together +c with a small s-value. unchanged on exit. +c s : real.on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments. +c nest : integer. on entry nest must contain an over-estimate of the +c total number of knots of the splines returned, to indicate +c the storage space available to the routine. nest >=2*k+2. +c in most practical situation nest=m/2 will be sufficient. +c always large enough is nest=m+2*k, the number of knots +c needed for interpolation (s=0). unchanged on exit. +c n : integer. +c unless ier = 10 (in case iopt >=0), n will contain the +c total number of knots of the smoothing spline curve returned +c if the computation mode iopt=1 is used this value of n +c should be left unchanged between subsequent calls. +c in case iopt=-1, the value of n must be specified on entry. +c t : real array of dimension at least (nest). +c on successful exit, this array will contain the knots of the +c spline curve,i.e. the position of the interior knots t(k+2), +c t(k+3),..,t(n-k-1) as well as the position of the additional +c t(1),t(2),..,t(k+1)=u(1) and u(m)=t(n-k),...,t(n) needed for +c the b-spline representation. +c if the computation mode iopt=1 is used, the values of t(1), +c t(2),...,t(n) should be left unchanged between subsequent +c calls. if the computation mode iopt=-1 is used, the values +c t(k+2),...,t(n-k-1) must be supplied by the user, before +c entry. see also the restrictions (ier=10). +c nc : integer. on entry nc must specify the actual dimension of +c the array c as declared in the calling (sub)program. nc +c must not be too small (see c). unchanged on exit. +c c : real array of dimension at least (nest*idim). +c on successful exit, this array will contain the coefficients +c in the b-spline representation of the spline curve s(u),i.e. +c the b-spline coefficients of the spline sj(u) will be given +c in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim. +c fp : real. unless ier = 10, fp contains the weighted sum of +c squared residuals of the spline curve returned. +c wrk : real array of dimension at least m*(k+1)+nest*(7+idim+5*k). +c used as working space. if the computation mode iopt=1 is +c used, the values wrk(1),...,wrk(n) should be left unchanged +c between subsequent calls. +c lwrk : integer. on entry,lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program. lwrk +c must not be too small (see wrk). unchanged on exit. +c iwrk : integer array of dimension at least (nest). +c used as working space. if the computation mode iopt=1 is +c used,the values iwrk(1),...,iwrk(n) should be left unchanged +c between subsequent calls. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the close curve returned has a residual +c sum of squares fp such that abs(fp-s)/s <= tol with tol a +c relative tolerance set to 0.001 by the program. +c ier=-1 : normal return. the curve returned is an interpolating +c spline curve (fp=0). +c ier=-2 : normal return. the curve returned is the weighted least- +c squares point,i.e. each spline sj(u) is a constant. in +c this extreme case fp gives the upper bound fp0 for the +c smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameter nest. +c probably causes : nest too small. if nest is already +c large (say nest > m/2), it may also indicate that s is +c too small +c the approximation returned is the least-squares closed +c curve according to the knots t(1),t(2),...,t(n). (n=nest) +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing curve with +c fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing curve +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 1<=k<=5, m>1, nest>2*k+2, w(i)>0,i=1,2,...,m +c 0<=ipar<=1, 0=(k+1)*m+nest*(7+idim+5*k), +c nc>=nest*idim, x(j)=x(idim*(m-1)+j), j=1,2,...,idim +c if ipar=0: sum j=1,idim (x(i*idim+j)-x((i-1)*idim+j))**2>0 +c i=1,2,...,m-1. +c if ipar=1: u(1)=0: s>=0 +c if s=0 : nest >= m+2*k +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the curve will be too smooth and signal will be +c lost ; if s is too small the curve will pick up too much noise. in +c the extreme cases the program will return an interpolating curve if +c s=0 and the weighted least-squares point if s is very large. +c between these extremes, a properly chosen s will result in a good +c compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c x(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in x(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the weighted +c least-squares point and the upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximating curve shows more detail) to obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if clocur is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c curve underlying the data. but, if the computation mode iopt=1 is +c used, the knots returned may also depend on the s-values at previous +c calls (if these were smaller). therefore, if after a number of +c trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c clocur once more with the selected value for s but now with iopt=0. +c indeed, clocur may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c +c the form of the approximating curve can strongly be affected by +c the choice of the parameter values u(i). if there is no physical +c reason for choosing a particular parameter u, often good results +c will be obtained with the choice of clocur(in case ipar=0), i.e. +c v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m +c where +c q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 ) +c other possibilities for q(i) are +c q(i)= sum j=1,idim (xj(i)-xj(i-1))**2 +c q(i)= sum j=1,idim abs(xj(i)-xj(i-1)) +c q(i)= max j=1,idim abs(xj(i)-xj(i-1)) +c q(i)= 1 +c +c +c other subroutines required: +c fpbacp,fpbspl,fpchep,fpclos,fpdisc,fpgivs,fpknot,fprati,fprota +c +c references: +c dierckx p. : algorithms for smoothing data with periodic and +c parametric splines, computer graphics and image +c processing 20 (1982) 171-184. +c dierckx p. : algorithms for smoothing data with periodic and param- +c etric splines, report tw55, dept. computer science, +c k.u.leuven, 1981. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + real*8 s,fp + integer iopt,ipar,idim,m,mx,k,nest,n,nc,lwrk,ier +c ..array arguments.. + real*8 u(m),x(mx),w(m),t(nest),c(nc),wrk(lwrk) + integer iwrk(nest) +c ..local scalars.. + real*8 per,tol,dist + integer i,ia1,ia2,ib,ifp,ig1,ig2,iq,iz,i1,i2,j1,j2,k1,k2,lwest, + * maxit,m1,nmin,ncc,j +c ..function references.. + real*8 sqrt +c we set up the parameters tol and maxit + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 90 + if(ipar.lt.0 .or. ipar.gt.1) go to 90 + if(idim.le.0 .or. idim.gt.10) go to 90 + if(k.le.0 .or. k.gt.5) go to 90 + k1 = k+1 + k2 = k1+1 + nmin = 2*k1 + if(m.lt.2 .or. nest.lt.nmin) go to 90 + ncc = nest*idim + if(mx.lt.m*idim .or. nc.lt.ncc) go to 90 + lwest = m*k1+nest*(7+idim+5*k) + if(lwrk.lt.lwest) go to 90 + i1 = idim + i2 = m*idim + do 5 j=1,idim + if(x(i1).ne.x(i2)) go to 90 + i1 = i1-1 + i2 = i2-1 + 5 continue + if(ipar.ne.0 .or. iopt.gt.0) go to 40 + i1 = 0 + i2 = idim + u(1) = 0. + do 20 i=2,m + dist = 0. + do 10 j1=1,idim + i1 = i1+1 + i2 = i2+1 + dist = dist+(x(i2)-x(i1))**2 + 10 continue + u(i) = u(i-1)+sqrt(dist) + 20 continue + if(u(m).le.0.) go to 90 + do 30 i=2,m + u(i) = u(i)/u(m) + 30 continue + u(m) = 0.1e+01 + 40 if(w(1).le.0.) go to 90 + m1 = m-1 + do 50 i=1,m1 + if(u(i).ge.u(i+1) .or. w(i).le.0.) go to 90 + 50 continue + if(iopt.ge.0) go to 70 + if(n.le.nmin .or. n.gt.nest) go to 90 + per = u(m)-u(1) + j1 = k1 + t(j1) = u(1) + i1 = n-k + t(i1) = u(m) + j2 = j1 + i2 = i1 + do 60 i=1,k + i1 = i1+1 + i2 = i2-1 + j1 = j1+1 + j2 = j2-1 + t(j2) = t(i2)-per + t(i1) = t(j1)+per + 60 continue + call fpchep(u,m,t,n,k,ier) + if (ier.eq.0) go to 80 + go to 90 + 70 if(s.lt.0.) go to 90 + if(s.eq.0. .and. nest.lt.(m+2*k)) go to 90 + ier = 0 +c we partition the working space and determine the spline approximation. + 80 ifp = 1 + iz = ifp+nest + ia1 = iz+ncc + ia2 = ia1+nest*k1 + ib = ia2+nest*k + ig1 = ib+nest*k2 + ig2 = ig1+nest*k2 + iq = ig2+nest*k1 + call fpclos(iopt,idim,m,u,mx,x,w,k,s,nest,tol,maxit,k1,k2,n,t, + * ncc,c,fp,wrk(ifp),wrk(iz),wrk(ia1),wrk(ia2),wrk(ib),wrk(ig1), + * wrk(ig2),wrk(iq),iwrk,ier) + 90 return + end diff --git a/fitpack/cocosp.f b/fitpack/cocosp.f new file mode 100644 index 0000000..071f4b9 --- /dev/null +++ b/fitpack/cocosp.f @@ -0,0 +1,181 @@ + recursive subroutine cocosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq, + * sx,bind,wrk,lwrk,iwrk,kwrk,ier) + implicit none +c given the set of data points (x(i),y(i)) and the set of positive +c numbers w(i),i=1,2,...,m, subroutine cocosp determines the weighted +c least-squares cubic spline s(x) with given knots t(j),j=1,2,...,n +c which satisfies the following concavity/convexity conditions +c s''(t(j+3))*e(j) <= 0, j=1,2,...n-6 +c the fit is given in the b-spline representation( b-spline coef- +c ficients c(j),j=1,2,...n-4) and can be evaluated by means of +c subroutine splev. +c +c calling sequence: +c call cocosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,wrk, +c * lwrk,iwrk,kwrk,ier) +c +c parameters: +c m : integer. on entry m must specify the number of data points. +c m > 3. unchanged on exit. +c x : real array of dimension at least (m). before entry, x(i) +c must be set to the i-th value of the independent variable x, +c for i=1,2,...,m. these values must be supplied in strictly +c ascending order. unchanged on exit. +c y : real array of dimension at least (m). before entry, y(i) +c must be set to the i-th value of the dependent variable y, +c for i=1,2,...,m. unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) +c must be set to the i-th value in the set of weights. the +c w(i) must be strictly positive. unchanged on exit. +c n : integer. on entry n must contain the total number of knots +c of the cubic spline. m+4>=n>=8. unchanged on exit. +c t : real array of dimension at least (n). before entry, this +c array must contain the knots of the spline, i.e. the position +c of the interior knots t(5),t(6),...,t(n-4) as well as the +c position of the boundary knots t(1),t(2),t(3),t(4) and t(n-3) +c t(n-2),t(n-1),t(n) needed for the b-spline representation. +c unchanged on exit. see also the restrictions (ier=10). +c e : real array of dimension at least (n). before entry, e(j) +c must be set to 1 if s(x) must be locally concave at t(j+3), +c to (-1) if s(x) must be locally convex at t(j+3) and to 0 +c if no convexity constraint is imposed at t(j+3),j=1,2,..,n-6. +c e(n-5),...,e(n) are not used. unchanged on exit. +c maxtr : integer. on entry maxtr must contain an over-estimate of the +c total number of records in the used tree structure, to indic- +c ate the storage space available to the routine. maxtr >=1 +c in most practical situation maxtr=100 will be sufficient. +c always large enough is +c n-5 n-6 +c maxtr = ( ) + ( ) with l the greatest +c l l+1 +c integer <= (n-6)/2 . unchanged on exit. +c maxbin: integer. on entry maxbin must contain an over-estimate of the +c number of knots where s(x) will have a zero second derivative +c maxbin >=1. in most practical situation maxbin = 10 will be +c sufficient. always large enough is maxbin=n-6. +c unchanged on exit. +c c : real array of dimension at least (n). +c on successful exit, this array will contain the coefficients +c c(1),c(2),..,c(n-4) in the b-spline representation of s(x) +c sq : real. on successful exit, sq contains the weighted sum of +c squared residuals of the spline approximation returned. +c sx : real array of dimension at least m. on successful exit +c this array will contain the spline values s(x(i)),i=1,...,m +c bind : logical array of dimension at least (n). on successful exit +c this array will indicate the knots where s''(x)=0, i.e. +c s''(t(j+3)) .eq. 0 if bind(j) = .true. +c s''(t(j+3)) .ne. 0 if bind(j) = .false., j=1,2,...,n-6 +c wrk : real array of dimension at least m*4+n*7+maxbin*(maxbin+n+1) +c used as working space. +c lwrk : integer. on entry,lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program.lwrk +c must not be too small (see wrk). unchanged on exit. +c iwrk : integer array of dimension at least (maxtr*4+2*(maxbin+1)) +c used as working space. +c kwrk : integer. on entry,kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. kwrk +c must not be too small (see iwrk). unchanged on exit. +c ier : integer. error flag +c ier=0 : successful exit. +c ier>0 : abnormal termination: no approximation is returned +c ier=1 : the number of knots where s''(x)=0 exceeds maxbin. +c probably causes : maxbin too small. +c ier=2 : the number of records in the tree structure exceeds +c maxtr. +c probably causes : maxtr too small. +c ier=3 : the algorithm finds no solution to the posed quadratic +c programming problem. +c probably causes : rounding errors. +c ier=10 : on entry, the input data are controlled on validity. +c the following restrictions must be satisfied +c m>3, maxtr>=1, maxbin>=1, 8<=n<=m+4,w(i) > 0, +c x(1)=maxtr*4+2*(maxbin+1), +c lwrk>=m*4+n*7+maxbin*(maxbin+n+1), +c the schoenberg-whitney conditions, i.e. there must +c be a subset of data points xx(j) such that +c t(j) < xx(j) < t(j+4), j=1,2,...,n-4 +c if one of these restrictions is found to be violated +c control is immediately repassed to the calling program +c +c +c other subroutines required: +c fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno,fpchec +c +c references: +c dierckx p. : an algorithm for cubic spline fitting with convexity +c constraints, computing 24 (1980) 349-371. +c dierckx p. : an algorithm for least-squares cubic spline fitting +c with convexity and concavity constraints, report tw39, +c dept. computer science, k.u.leuven, 1978. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p. dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : march 1978 +c latest update : march 1987. +c +c .. +c ..scalar arguments.. + real*8 sq + integer m,n,maxtr,maxbin,lwrk,kwrk,ier +c ..array arguments.. + real*8 x(m),y(m),w(m),t(n),e(n),c(n),sx(m),wrk(lwrk) + integer iwrk(kwrk) + logical bind(n) +c ..local scalars.. + integer i,ia,ib,ic,iq,iu,iz,izz,ji,jib,jjb,jl,jr,ju,kwest, + * lwest,mb,nm,n6 + real*8 one +c .. +c set constant + one = 0.1e+01 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(m.lt.4 .or. n.lt.8) go to 40 + if(maxtr.lt.1 .or. maxbin.lt.1) go to 40 + lwest = 7*n+m*4+maxbin*(1+n+maxbin) + kwest = 4*maxtr+2*(maxbin+1) + if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 40 + if(w(1).le.0.) go to 40 + do 10 i=2,m + if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 40 + 10 continue + call fpchec(x,m,t,n,3,ier) + if (ier.eq.0) go to 20 + go to 40 +c set numbers e(i) + 20 n6 = n-6 + do 30 i=1,n6 + if(e(i).gt.0.) e(i) = one + if(e(i).lt.0.) e(i) = -one + 30 continue +c we partition the working space and determine the spline approximation + nm = n+maxbin + mb = maxbin+1 + ia = 1 + ib = ia+4*n + ic = ib+nm*maxbin + iz = ic+n + izz = iz+n + iu = izz+n + iq = iu+maxbin + ji = 1 + ju = ji+maxtr + jl = ju+maxtr + jr = jl+maxtr + jjb = jr+maxtr + jib = jjb+mb + call fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,wrk(ia), + * + * wrk(ib),wrk(ic),wrk(iz),wrk(izz),wrk(iu),wrk(iq),iwrk(ji), + * iwrk(ju),iwrk(jl),iwrk(jr),iwrk(jjb),iwrk(jib),ier) + 40 return + end diff --git a/fitpack/concon.f b/fitpack/concon.f new file mode 100644 index 0000000..1b0a0ea --- /dev/null +++ b/fitpack/concon.f @@ -0,0 +1,234 @@ + recursive subroutine concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin, + * n,t,c,sq,sx,bind,wrk,lwrk,iwrk,kwrk,ier) + implicit none +c given the set of data points (x(i),y(i)) and the set of positive +c numbers w(i), i=1,2,...,m,subroutine concon determines a cubic spline +c approximation s(x) which satisfies the following local convexity +c constraints s''(x(i))*v(i) <= 0, i=1,2,...,m. +c the number of knots n and the position t(j),j=1,2,...n is chosen +c automatically by the routine in a way that +c sq = sum((w(i)*(y(i)-s(x(i))))**2) be <= s. +c the fit is given in the b-spline representation (b-spline coef- +c ficients c(j),j=1,2,...n-4) and can be evaluated by means of +c subroutine splev. +c +c calling sequence: +c +c call concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq, +c * sx,bind,wrk,lwrk,iwrk,kwrk,ier) +c +c parameters: +c iopt: integer flag. +c if iopt=0, the routine will start with the minimal number of +c knots to guarantee that the convexity conditions will be +c satisfied. if iopt=1, the routine will continue with the set +c of knots found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately +c preceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m > 3. unchanged on exit. +c x : real array of dimension at least (m). before entry, x(i) +c must be set to the i-th value of the independent variable x, +c for i=1,2,...,m. these values must be supplied in strictly +c ascending order. unchanged on exit. +c y : real array of dimension at least (m). before entry, y(i) +c must be set to the i-th value of the dependent variable y, +c for i=1,2,...,m. unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) +c must be set to the i-th value in the set of weights. the +c w(i) must be strictly positive. unchanged on exit. +c v : real array of dimension at least (m). before entry, v(i) +c must be set to 1 if s(x) must be locally concave at x(i), +c to (-1) if s(x) must be locally convex at x(i) and to 0 +c if no convexity constraint is imposed at x(i). +c s : real. on entry s must specify an over-estimate for the +c the weighted sum of squared residuals sq of the requested +c spline. s >=0. unchanged on exit. +c nest : integer. on entry nest must contain an over-estimate of the +c total number of knots of the spline returned, to indicate +c the storage space available to the routine. nest >=8. +c in most practical situation nest=m/2 will be sufficient. +c always large enough is nest=m+4. unchanged on exit. +c maxtr : integer. on entry maxtr must contain an over-estimate of the +c total number of records in the used tree structure, to indic- +c ate the storage space available to the routine. maxtr >=1 +c in most practical situation maxtr=100 will be sufficient. +c always large enough is +c nest-5 nest-6 +c maxtr = ( ) + ( ) with l the greatest +c l l+1 +c integer <= (nest-6)/2 . unchanged on exit. +c maxbin: integer. on entry maxbin must contain an over-estimate of the +c number of knots where s(x) will have a zero second derivative +c maxbin >=1. in most practical situation maxbin = 10 will be +c sufficient. always large enough is maxbin=nest-6. +c unchanged on exit. +c n : integer. +c on exit with ier <=0, n will contain the total number of +c knots of the spline approximation returned. if the comput- +c ation mode iopt=1 is used this value of n should be left +c unchanged between subsequent calls. +c t : real array of dimension at least (nest). +c on exit with ier<=0, this array will contain the knots of the +c spline,i.e. the position of the interior knots t(5),t(6),..., +c t(n-4) as well as the position of the additional knots +c t(1)=t(2)=t(3)=t(4)=x(1) and t(n-3)=t(n-2)=t(n-1)=t(n)=x(m) +c needed for the b-spline representation. +c if the computation mode iopt=1 is used, the values of t(1), +c t(2),...,t(n) should be left unchanged between subsequent +c calls. +c c : real array of dimension at least (nest). +c on successful exit, this array will contain the coefficients +c c(1),c(2),..,c(n-4) in the b-spline representation of s(x) +c sq : real. unless ier>0 , sq contains the weighted sum of +c squared residuals of the spline approximation returned. +c sx : real array of dimension at least m. on exit with ier<=0 +c this array will contain the spline values s(x(i)),i=1,...,m +c if the computation mode iopt=1 is used, the values of sx(1), +c sx(2),...,sx(m) should be left unchanged between subsequent +c calls. +c bind: logical array of dimension at least nest. on exit with ier<=0 +c this array will indicate the knots where s''(x)=0, i.e. +c s''(t(j+3)) .eq. 0 if bind(j) = .true. +c s''(t(j+3)) .ne. 0 if bind(j) = .false., j=1,2,...,n-6 +c if the computation mode iopt=1 is used, the values of bind(1) +c ,...,bind(n-6) should be left unchanged between subsequent +c calls. +c wrk : real array of dimension at least (m*4+nest*8+maxbin*(maxbin+ +c nest+1)). used as working space. +c lwrk : integer. on entry,lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program.lwrk +c must not be too small (see wrk). unchanged on exit. +c iwrk : integer array of dimension at least (maxtr*4+2*(maxbin+1)) +c used as working space. +c kwrk : integer. on entry,kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. kwrk +c must not be too small (see iwrk). unchanged on exit. +c ier : integer. error flag +c ier=0 : normal return, s(x) satisfies the concavity/convexity +c constraints and sq <= s. +c ier<0 : abnormal termination: s(x) satisfies the concavity/ +c convexity constraints but sq > s. +c ier=-3 : the requested storage space exceeds the available +c storage space as specified by the parameter nest. +c probably causes: nest too small. if nest is already +c large (say nest > m/2), it may also indicate that s +c is too small. +c the approximation returned is the least-squares cubic +c spline according to the knots t(1),...,t(n) (n=nest) +c which satisfies the convexity constraints. +c ier=-2 : the maximal number of knots n=m+4 has been reached. +c probably causes: s too small. +c ier=-1 : the number of knots n is less than the maximal number +c m+4 but concon finds that adding one or more knots +c will not further reduce the value of sq. +c probably causes : s too small. +c ier>0 : abnormal termination: no approximation is returned +c ier=1 : the number of knots where s''(x)=0 exceeds maxbin. +c probably causes : maxbin too small. +c ier=2 : the number of records in the tree structure exceeds +c maxtr. +c probably causes : maxtr too small. +c ier=3 : the algorithm finds no solution to the posed quadratic +c programming problem. +c probably causes : rounding errors. +c ier=4 : the minimum number of knots (given by n) to guarantee +c that the concavity/convexity conditions will be +c satisfied is greater than nest. +c probably causes: nest too small. +c ier=5 : the minimum number of knots (given by n) to guarantee +c that the concavity/convexity conditions will be +c satisfied is greater than m+4. +c probably causes: strongly alternating convexity and +c concavity conditions. normally the situation can be +c coped with by adding n-m-4 extra data points (found +c by linear interpolation e.g.) with a small weight w(i) +c and a v(i) number equal to zero. +c ier=10 : on entry, the input data are controlled on validity. +c the following restrictions must be satisfied +c 0<=iopt<=1, m>3, nest>=8, s>=0, maxtr>=1, maxbin>=1, +c kwrk>=maxtr*4+2*(maxbin+1), w(i)>0, x(i) < x(i+1), +c lwrk>=m*4+nest*8+maxbin*(maxbin+nest+1) +c if one of these restrictions is found to be violated +c control is immediately repassed to the calling program +c +c further comments: +c as an example of the use of the computation mode iopt=1, the +c following program segment will cause concon to return control +c each time a spline with a new set of knots has been computed. +c ............. +c iopt = 0 +c s = 0.1e+60 (s very large) +c do 10 i=1,m +c call concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx, +c * bind,wrk,lwrk,iwrk,kwrk,ier) +c ...... +c s = sq +c iopt=1 +c 10 continue +c ............. +c +c other subroutines required: +c fpcoco,fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno +c +c references: +c dierckx p. : an algorithm for cubic spline fitting with convexity +c constraints, computing 24 (1980) 349-371. +c dierckx p. : an algorithm for least-squares cubic spline fitting +c with convexity and concavity constraints, report tw39, +c dept. computer science, k.u.leuven, 1978. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p. dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : march 1978 +c latest update : march 1987. +c +c .. +c ..scalar arguments.. + real*8 s,sq + integer iopt,m,nest,maxtr,maxbin,n,lwrk,kwrk,ier +c ..array arguments.. + real*8 x(m),y(m),w(m),v(m),t(nest),c(nest),sx(m),wrk(lwrk) + integer iwrk(kwrk) + logical bind(nest) +c ..local scalars.. + integer i,lwest,kwest,ie,iw,lww + real*8 one +c .. +c set constant + one = 0.1e+01 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(iopt.lt.0 .or. iopt.gt.1) go to 30 + if(m.lt.4 .or. nest.lt.8) go to 30 + if(s.lt.0.) go to 30 + if(maxtr.lt.1 .or. maxbin.lt.1) go to 30 + lwest = 8*nest+m*4+maxbin*(1+nest+maxbin) + kwest = 4*maxtr+2*(maxbin+1) + if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 30 + if(iopt.gt.0) go to 20 + if(w(1).le.0.) go to 30 + if(v(1).gt.0.) v(1) = one + if(v(1).lt.0.) v(1) = -one + do 10 i=2,m + if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 30 + if(v(i).gt.0.) v(i) = one + if(v(i).lt.0.) v(i) = -one + 10 continue + 20 ier = 0 +c we partition the working space and determine the spline approximation + ie = 1 + iw = ie+nest + lww = lwrk-nest + call fpcoco(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx, + * bind,wrk(ie),wrk(iw),lww,iwrk,kwrk,ier) + 30 return + end diff --git a/fitpack/concur.f b/fitpack/concur.f new file mode 100644 index 0000000..271fd75 --- /dev/null +++ b/fitpack/concur.f @@ -0,0 +1,371 @@ + recursive subroutine concur(iopt,idim,m,u,mx,x,xx,w,ib,db,nb, + * ie,de,ne,k,s,nest,n,t,nc,c,np,cp,fp,wrk,lwrk,iwrk,ier) + implicit none +c given the ordered set of m points x(i) in the idim-dimensional space +c and given also a corresponding set of strictly increasing values u(i) +c and the set of positive numbers w(i),i=1,2,...,m, subroutine concur +c determines a smooth approximating spline curve s(u), i.e. +c x1 = s1(u) +c x2 = s2(u) ub = u(1) <= u <= u(m) = ue +c ......... +c xidim = sidim(u) +c with sj(u),j=1,2,...,idim spline functions of odd degree k with +c common knots t(j),j=1,2,...,n. +c in addition these splines will satisfy the following boundary +c constraints (l) +c if ib > 0 : sj (u(1)) = db(idim*l+j) ,l=0,1,...,ib-1 +c and (l) +c if ie > 0 : sj (u(m)) = de(idim*l+j) ,l=0,1,...,ie-1. +c if iopt=-1 concur calculates the weighted least-squares spline curve +c according to a given set of knots. +c if iopt>=0 the number of knots of the splines sj(u) and the position +c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- +c ness of s(u) is then achieved by minimalizing the discontinuity +c jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,..., +c n-k-1. the amount of smoothness is determined by the condition that +c f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non- +c negative constant, called the smoothing factor. +c the fit s(u) is given in the b-spline representation and can be +c evaluated by means of subroutine curev. +c +c calling sequence: +c call concur(iopt,idim,m,u,mx,x,xx,w,ib,db,nb,ie,de,ne,k,s,nest,n, +c * t,nc,c,np,cp,fp,wrk,lwrk,iwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a weighted +c least-squares spline curve (iopt=-1) or a smoothing spline +c curve (iopt=0 or 1) must be determined.if iopt=0 the routine +c will start with an initial set of knots t(i)=ub,t(i+k+1)=ue, +c i=1,2,...,k+1. if iopt=1 the routine will continue with the +c knots found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately +c preceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c idim : integer. on entry idim must specify the dimension of the +c curve. 0 < idim < 11. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m > k-max(ib-1,0)-max(ie-1,0). unchanged on exit. +c u : real array of dimension at least (m). before entry, +c u(i) must be set to the i-th value of the parameter variable +c u for i=1,2,...,m. these values must be supplied in +c strictly ascending order and will be unchanged on exit. +c mx : integer. on entry mx must specify the actual dimension of +c the arrays x and xx as declared in the calling (sub)program +c mx must not be too small (see x). unchanged on exit. +c x : real array of dimension at least idim*m. +c before entry, x(idim*(i-1)+j) must contain the j-th coord- +c inate of the i-th data point for i=1,2,...,m and j=1,2,..., +c idim. unchanged on exit. +c xx : real array of dimension at least idim*m. +c used as working space. on exit xx contains the coordinates +c of the data points to which a spline curve with zero deriv- +c ative constraints has been determined. +c if the computation mode iopt =1 is used xx should be left +c unchanged between calls. +c w : real array of dimension at least (m). before entry, w(i) +c must be set to the i-th value in the set of weights. the +c w(i) must be strictly positive. unchanged on exit. +c see also further comments. +c ib : integer. on entry ib must specify the number of derivative +c constraints for the curve at the begin point. 0<=ib<=(k+1)/2 +c unchanged on exit. +c db : real array of dimension nb. before entry db(idim*l+j) must +c contain the l-th order derivative of sj(u) at u=u(1) for +c j=1,2,...,idim and l=0,1,...,ib-1 (if ib>0). +c unchanged on exit. +c nb : integer, specifying the dimension of db. nb>=max(1,idim*ib) +c unchanged on exit. +c ie : integer. on entry ie must specify the number of derivative +c constraints for the curve at the end point. 0<=ie<=(k+1)/2 +c unchanged on exit. +c de : real array of dimension ne. before entry de(idim*l+j) must +c contain the l-th order derivative of sj(u) at u=u(m) for +c j=1,2,...,idim and l=0,1,...,ie-1 (if ie>0). +c unchanged on exit. +c ne : integer, specifying the dimension of de. ne>=max(1,idim*ie) +c unchanged on exit. +c k : integer. on entry k must specify the degree of the splines. +c k=1,3 or 5. +c unchanged on exit. +c s : real.on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments. +c nest : integer. on entry nest must contain an over-estimate of the +c total number of knots of the splines returned, to indicate +c the storage space available to the routine. nest >=2*k+2. +c in most practical situation nest=m/2 will be sufficient. +c always large enough is nest=m+k+1+max(0,ib-1)+max(0,ie-1), +c the number of knots needed for interpolation (s=0). +c unchanged on exit. +c n : integer. +c unless ier = 10 (in case iopt >=0), n will contain the +c total number of knots of the smoothing spline curve returned +c if the computation mode iopt=1 is used this value of n +c should be left unchanged between subsequent calls. +c in case iopt=-1, the value of n must be specified on entry. +c t : real array of dimension at least (nest). +c on successful exit, this array will contain the knots of the +c spline curve,i.e. the position of the interior knots t(k+2), +c t(k+3),..,t(n-k-1) as well as the position of the additional +c t(1)=t(2)=...=t(k+1)=ub and t(n-k)=...=t(n)=ue needed for +c the b-spline representation. +c if the computation mode iopt=1 is used, the values of t(1), +c t(2),...,t(n) should be left unchanged between subsequent +c calls. if the computation mode iopt=-1 is used, the values +c t(k+2),...,t(n-k-1) must be supplied by the user, before +c entry. see also the restrictions (ier=10). +c nc : integer. on entry nc must specify the actual dimension of +c the array c as declared in the calling (sub)program. nc +c must not be too small (see c). unchanged on exit. +c c : real array of dimension at least (nest*idim). +c on successful exit, this array will contain the coefficients +c in the b-spline representation of the spline curve s(u),i.e. +c the b-spline coefficients of the spline sj(u) will be given +c in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim. +c cp : real array of dimension at least 2*(k+1)*idim. +c on exit cp will contain the b-spline coefficients of a +c polynomial curve which satisfies the boundary constraints. +c if the computation mode iopt =1 is used cp should be left +c unchanged between calls. +c np : integer. on entry np must specify the actual dimension of +c the array cp as declared in the calling (sub)program. np +c must not be too small (see cp). unchanged on exit. +c fp : real. unless ier = 10, fp contains the weighted sum of +c squared residuals of the spline curve returned. +c wrk : real array of dimension at least m*(k+1)+nest*(6+idim+3*k). +c used as working space. if the computation mode iopt=1 is +c used, the values wrk(1),...,wrk(n) should be left unchanged +c between subsequent calls. +c lwrk : integer. on entry,lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program. lwrk +c must not be too small (see wrk). unchanged on exit. +c iwrk : integer array of dimension at least (nest). +c used as working space. if the computation mode iopt=1 is +c used,the values iwrk(1),...,iwrk(n) should be left unchanged +c between subsequent calls. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the curve returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the curve returned is an interpolating +c spline curve, satisfying the constraints (fp=0). +c ier=-2 : normal return. the curve returned is the weighted least- +c squares polynomial curve of degree k, satisfying the +c constraints. in this extreme case fp gives the upper +c bound fp0 for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameter nest. +c probably causes : nest too small. if nest is already +c large (say nest > m/2), it may also indicate that s is +c too small +c the approximation returned is the least-squares spline +c curve according to the knots t(1),t(2),...,t(n). (n=nest) +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline curve +c with fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing curve +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, k = 1,3 or 5, m>k-max(0,ib-1)-max(0,ie-1), +c nest>=2k+2, 0=(k+1)*m+nest*(6+idim+3*k), +c nc >=nest*idim ,u(1)0 i=1,2,...,m, +c mx>=idim*m,0<=ib<=(k+1)/2,0<=ie<=(k+1)/2,nb>=1,ne>=1, +c nb>=ib*idim,ne>=ib*idim,np>=2*(k+1)*idim, +c if iopt=-1:2*k+2<=n<=min(nest,mmax) with mmax = m+k+1+ +c max(0,ib-1)+max(0,ie-1) +c u(1)=0: s>=0 +c if s=0 : nest >=mmax (see above) +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the curve will be too smooth and signal will be +c lost ; if s is too small the curve will pick up too much noise. in +c the extreme cases the program will return an interpolating curve if +c s=0 and the least-squares polynomial curve of degree k if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c x(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in x(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the least-squares +c polynomial curve and the upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximating curve shows more detail) to obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if concur is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c curve underlying the data. but, if the computation mode iopt=1 is +c used, the knots returned may also depend on the s-values at previous +c calls (if these were smaller). therefore, if after a number of +c trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c concur once more with the selected value for s but now with iopt=0. +c indeed, concur may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c +c the form of the approximating curve can strongly be affected by +c the choice of the parameter values u(i). if there is no physical +c reason for choosing a particular parameter u, often good results +c will be obtained with the choice +c v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m +c where +c q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 ) +c other possibilities for q(i) are +c q(i)= sum j=1,idim (xj(i)-xj(i-1))**2 +c q(i)= sum j=1,idim abs(xj(i)-xj(i-1)) +c q(i)= max j=1,idim abs(xj(i)-xj(i-1)) +c q(i)= 1 +c +c other subroutines required: +c fpback,fpbspl,fpched,fpcons,fpdisc,fpgivs,fpknot,fprati,fprota +c curev,fppocu,fpadpo,fpinst +c +c references: +c dierckx p. : algorithms for smoothing data with periodic and +c parametric splines, computer graphics and image +c processing 20 (1982) 171-184. +c dierckx p. : algorithms for smoothing data with periodic and param- +c etric splines, report tw55, dept. computer science, +c k.u.leuven, 1981. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + real*8 s,fp + integer iopt,idim,m,mx,ib,nb,ie,ne,k,nest,n,nc,np,lwrk,ier +c ..array arguments.. + real*8 u(m),x(mx),xx(mx),db(nb),de(ne),w(m),t(nest),c(nc),wrk(lwrk + *) + real*8 cp(np) + integer iwrk(nest) +c ..local scalars.. + real*8 tol + integer i,ib1,ie1,ja,jb,jfp,jg,jq,jz,j,k1,k2,lwest,maxit,nmin, + * ncc,kk,mmin,nmax,mxx +c ..function references + integer max0 +c .. +c we set up the parameters tol and maxit + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 90 + if(idim.le.0 .or. idim.gt.10) go to 90 + if(k.le.0 .or. k.gt.5) go to 90 + k1 = k+1 + kk = k1/2 + if(kk*2.ne.k1) go to 90 + k2 = k1+1 + if(ib.lt.0 .or. ib.gt.kk) go to 90 + if(ie.lt.0 .or. ie.gt.kk) go to 90 + nmin = 2*k1 + ib1 = max0(0,ib-1) + ie1 = max0(0,ie-1) + mmin = k1-ib1-ie1 + if(m.lt.mmin .or. nest.lt.nmin) go to 90 + if(nb.lt.(idim*ib) .or. ne.lt.(idim*ie)) go to 90 + if(np.lt.(2*k1*idim)) go to 90 + mxx = m*idim + ncc = nest*idim + if(mx.lt.mxx .or. nc.lt.ncc) go to 90 + lwest = m*k1+nest*(6+idim+3*k) + if(lwrk.lt.lwest) go to 90 + if(w(1).le.0.) go to 90 + do 10 i=2,m + if(u(i-1).ge.u(i) .or. w(i).le.0.) go to 90 + 10 continue + if(iopt.ge.0) go to 30 + if(n.lt.nmin .or. n.gt.nest) go to 90 + j = n + do 20 i=1,k1 + t(i) = u(1) + t(j) = u(m) + j = j-1 + 20 continue + call fpched(u,m,t,n,k,ib,ie,ier) + if (ier.eq.0) go to 40 + go to 90 + 30 if(s.lt.0.) go to 90 + nmax = m+k1+ib1+ie1 + if(s.eq.0. .and. nest.lt.nmax) go to 90 + ier = 0 + if(iopt.gt.0) go to 70 +c we determine a polynomial curve satisfying the boundary constraints. + 40 call fppocu(idim,k,u(1),u(m),ib,db,nb,ie,de,ne,cp,np) +c we generate new data points which will be approximated by a spline +c with zero derivative constraints. + j = nmin + do 50 i=1,k1 + wrk(i) = u(1) + wrk(j) = u(m) + j = j-1 + 50 continue +c evaluate the polynomial curve + call curev(idim,wrk,nmin,cp,np,k,u,m,xx,mxx,ier) +c subtract from the old data, the values of the polynomial curve + do 60 i=1,mxx + xx(i) = x(i)-xx(i) + 60 continue +c we partition the working space and determine the spline curve. + 70 jfp = 1 + jz = jfp+nest + ja = jz+ncc + jb = ja+nest*k1 + jg = jb+nest*k2 + jq = jg+nest*k2 + call fpcons(iopt,idim,m,u,mxx,xx,w,ib,ie,k,s,nest,tol,maxit,k1, + * k2,n,t,ncc,c,fp,wrk(jfp),wrk(jz),wrk(ja),wrk(jb),wrk(jg),wrk(jq), + * + * iwrk,ier) +c add the polynomial curve to the calculated spline. + call fpadpo(idim,t,n,c,ncc,k,cp,np,wrk(jz),wrk(ja),wrk(jb)) + 90 return + end diff --git a/fitpack/cualde.f b/fitpack/cualde.f new file mode 100644 index 0000000..a941507 --- /dev/null +++ b/fitpack/cualde.f @@ -0,0 +1,92 @@ + recursive subroutine cualde(idim,t,n,c,nc,k1,u,d,nd,ier) + implicit none +c subroutine cualde evaluates at the point u all the derivatives +c (l) +c d(idim*l+j) = sj (u) ,l=0,1,...,k, j=1,2,...,idim +c of a spline curve s(u) of order k1 (degree k=k1-1) and dimension idim +c given in its b-spline representation. +c +c calling sequence: +c call cualde(idim,t,n,c,nc,k1,u,d,nd,ier) +c +c input parameters: +c idim : integer, giving the dimension of the spline curve. +c t : array,length n, which contains the position of the knots. +c n : integer, giving the total number of knots of s(u). +c c : array,length nc, which contains the b-spline coefficients. +c nc : integer, giving the total number of coefficients of s(u). +c k1 : integer, giving the order of s(u) (order=degree+1). +c u : real, which contains the point where the derivatives must +c be evaluated. +c nd : integer, giving the dimension of the array d. nd >= k1*idim +c +c output parameters: +c d : array,length nd,giving the different curve derivatives. +c d(idim*l+j) will contain the j-th coordinate of the l-th +c derivative of the curve at the point u. +c ier : error flag +c ier = 0 : normal return +c ier =10 : invalid input data (see restrictions) +c +c restrictions: +c nd >= k1*idim +c t(k1) <= u <= t(n-k1+1) +c +c further comments: +c if u coincides with a knot, right derivatives are computed +c ( left derivatives if u = t(n-k1+1) ). +c +c other subroutines required: fpader. +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer idim,n,nc,k1,nd,ier + real*8 u +c ..array arguments.. + real*8 t(n),c(nc),d(nd) +c ..local scalars.. + integer i,j,kk,l,m,nk1 +c ..local array.. + real*8 h(6) +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + if(nd.lt.(k1*idim)) go to 500 + nk1 = n-k1 + if(u.lt.t(k1) .or. u.gt.t(nk1+1)) go to 500 +c search for knot interval t(l) <= u < t(l+1) + l = k1 + 100 if(u.lt.t(l+1) .or. l.eq.nk1) go to 200 + l = l+1 + go to 100 + 200 if(t(l).ge.t(l+1)) go to 500 + ier = 0 +c calculate the derivatives. + j = 1 + do 400 i=1,idim + call fpader(t,n,c(j),k1,u,l,h) + m = i + do 300 kk=1,k1 + d(m) = h(kk) + m = m+idim + 300 continue + j = j+n + 400 continue + 500 return + end diff --git a/fitpack/curev.f b/fitpack/curev.f new file mode 100644 index 0000000..41d7ca5 --- /dev/null +++ b/fitpack/curev.f @@ -0,0 +1,111 @@ + recursive subroutine curev(idim,t,n,c,nc,k,u,m,x,mx,ier) + implicit none +c subroutine curev evaluates in a number of points u(i),i=1,2,...,m +c a spline curve s(u) of degree k and dimension idim, given in its +c b-spline representation. +c +c calling sequence: +c call curev(idim,t,n,c,nc,k,u,m,x,mx,ier) +c +c input parameters: +c idim : integer, giving the dimension of the spline curve. +c t : array,length n, which contains the position of the knots. +c n : integer, giving the total number of knots of s(u). +c c : array,length nc, which contains the b-spline coefficients. +c nc : integer, giving the total number of coefficients of s(u). +c k : integer, giving the degree of s(u). +c u : array,length m, which contains the points where s(u) must +c be evaluated. +c m : integer, giving the number of points where s(u) must be +c evaluated. +c mx : integer, giving the dimension of the array x. mx >= m*idim +c +c output parameters: +c x : array,length mx,giving the value of s(u) at the different +c points. x(idim*(i-1)+j) will contain the j-th coordinate +c of the i-th point on the curve. +c ier : error flag +c ier = 0 : normal return +c ier =10 : invalid input data (see restrictions) +c +c restrictions: +c m >= 1 +c mx >= m*idim +c t(k+1) <= u(i) <= u(i+1) <= t(n-k) , i=1,2,...,m-1. +c +c other subroutines required: fpbspl. +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer idim,n,nc,k,m,mx,ier +c ..array arguments.. + real*8 t(n),c(nc),u(m),x(mx) +c ..local scalars.. + integer i,j,jj,j1,k1,l,ll,l1,mm,nk1 + real*8 arg,sp,tb,te +c ..local array.. + real*8 h(6) +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + if (m.lt.1) go to 100 + if (m.eq.1) go to 30 + go to 10 + 10 do 20 i=2,m + if(u(i).lt.u(i-1)) go to 100 + 20 continue + 30 if(mx.lt.(m*idim)) go to 100 + ier = 0 +c fetch tb and te, the boundaries of the approximation interval. + k1 = k+1 + nk1 = n-k1 + tb = t(k1) + te = t(nk1+1) + l = k1 + l1 = l+1 +c main loop for the different points. + mm = 0 + do 80 i=1,m +c fetch a new u-value arg. + arg = u(i) + if(arg.lt.tb) arg = tb + if(arg.gt.te) arg = te +c search for knot interval t(l) <= arg < t(l+1) + 40 if(arg.lt.t(l1) .or. l.eq.nk1) go to 50 + l = l1 + l1 = l+1 + go to 40 +c evaluate the non-zero b-splines at arg. + 50 call fpbspl(t,n,k,arg,l,h) +c find the value of s(u) at u=arg. + ll = l-k1 + do 70 j1=1,idim + jj = ll + sp = 0. + do 60 j=1,k1 + jj = jj+1 + sp = sp+c(jj)*h(j) + 60 continue + mm = mm+1 + x(mm) = sp + ll = ll+n + 70 continue + 80 continue + 100 return + end diff --git a/fitpack/curfit.f b/fitpack/curfit.f new file mode 100644 index 0000000..3e4a586 --- /dev/null +++ b/fitpack/curfit.f @@ -0,0 +1,261 @@ + recursive subroutine curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n, + * t,c,fp,wrk,lwrk,iwrk,ier) + implicit none +c given the set of data points (x(i),y(i)) and the set of positive +c numbers w(i),i=1,2,...,m,subroutine curfit determines a smooth spline +c approximation of degree k on the interval xb <= x <= xe. +c if iopt=-1 curfit calculates the weighted least-squares spline +c according to a given set of knots. +c if iopt>=0 the number of knots of the spline s(x) and the position +c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- +c ness of s(x) is then achieved by minimalizing the discontinuity +c jumps of the k-th derivative of s(x) at the knots t(j),j=k+2,k+3,..., +c n-k-1. the amount of smoothness is determined by the condition that +c f(p)=sum((w(i)*(y(i)-s(x(i))))**2) be <= s, with s a given non- +c negative constant, called the smoothing factor. +c the fit s(x) is given in the b-spline representation (b-spline coef- +c ficients c(j),j=1,2,...,n-k-1) and can be evaluated by means of +c subroutine splev. +c +c calling sequence: +c call curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,wrk, +c * lwrk,iwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a weighted +c least-squares spline (iopt=-1) or a smoothing spline (iopt= +c 0 or 1) must be determined. if iopt=0 the routine will start +c with an initial set of knots t(i)=xb, t(i+k+1)=xe, i=1,2,... +c k+1. if iopt=1 the routine will continue with the knots +c found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately +c preceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m > k. unchanged on exit. +c x : real array of dimension at least (m). before entry, x(i) +c must be set to the i-th value of the independent variable x, +c for i=1,2,...,m. these values must be supplied in strictly +c ascending order. unchanged on exit. +c y : real array of dimension at least (m). before entry, y(i) +c must be set to the i-th value of the dependent variable y, +c for i=1,2,...,m. unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) +c must be set to the i-th value in the set of weights. the +c w(i) must be strictly positive. unchanged on exit. +c see also further comments. +c xb,xe : real values. on entry xb and xe must specify the boundaries +c of the approximation interval. xb<=x(1), xe>=x(m). +c unchanged on exit. +c k : integer. on entry k must specify the degree of the spline. +c 1<=k<=5. it is recommended to use cubic splines (k=3). +c the user is strongly dissuaded from choosing k even,together +c with a small s-value. unchanged on exit. +c s : real.on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments. +c nest : integer. on entry nest must contain an over-estimate of the +c total number of knots of the spline returned, to indicate +c the storage space available to the routine. nest >=2*k+2. +c in most practical situation nest=m/2 will be sufficient. +c always large enough is nest=m+k+1, the number of knots +c needed for interpolation (s=0). unchanged on exit. +c n : integer. +c unless ier =10 (in case iopt >=0), n will contain the +c total number of knots of the spline approximation returned. +c if the computation mode iopt=1 is used this value of n +c should be left unchanged between subsequent calls. +c in case iopt=-1, the value of n must be specified on entry. +c t : real array of dimension at least (nest). +c on successful exit, this array will contain the knots of the +c spline,i.e. the position of the interior knots t(k+2),t(k+3) +c ...,t(n-k-1) as well as the position of the additional knots +c t(1)=t(2)=...=t(k+1)=xb and t(n-k)=...=t(n)=xe needed for +c the b-spline representation. +c if the computation mode iopt=1 is used, the values of t(1), +c t(2),...,t(n) should be left unchanged between subsequent +c calls. if the computation mode iopt=-1 is used, the values +c t(k+2),...,t(n-k-1) must be supplied by the user, before +c entry. see also the restrictions (ier=10). +c c : real array of dimension at least (nest). +c on successful exit, this array will contain the coefficients +c c(1),c(2),..,c(n-k-1) in the b-spline representation of s(x) +c fp : real. unless ier=10, fp contains the weighted sum of +c squared residuals of the spline approximation returned. +c wrk : real array of dimension at least (m*(k+1)+nest*(7+3*k)). +c used as working space. if the computation mode iopt=1 is +c used, the values wrk(1),...,wrk(n) should be left unchanged +c between subsequent calls. +c lwrk : integer. on entry,lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program.lwrk +c must not be too small (see wrk). unchanged on exit. +c iwrk : integer array of dimension at least (nest). +c used as working space. if the computation mode iopt=1 is +c used,the values iwrk(1),...,iwrk(n) should be left unchanged +c between subsequent calls. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c spline (fp=0). +c ier=-2 : normal return. the spline returned is the weighted least- +c squares polynomial of degree k. in this extreme case fp +c gives the upper bound fp0 for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameter nest. +c probably causes : nest too small. if nest is already +c large (say nest > m/2), it may also indicate that s is +c too small +c the approximation returned is the weighted least-squares +c spline according to the knots t(1),t(2),...,t(n). (n=nest) +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline with +c fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 1<=k<=5, m>k, nest>2*k+2, w(i)>0,i=1,2,...,m +c xb<=x(1)=(k+1)*m+nest*(7+3*k) +c if iopt=-1: 2*k+2<=n<=min(nest,m+k+1) +c xb=0: s>=0 +c if s=0 : nest >= m+k+1 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the weighted least-squares polynomial of degree k if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c y(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in y(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the least-squares +c polynomial and the corresponding upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximation shows more detail) to obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if curfit is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. but, if the computation mode iopt=1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c curfit once more with the selected value for s but now with iopt=0. +c indeed, curfit may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c +c other subroutines required: +c fpback,fpbspl,fpchec,fpcurf,fpdisc,fpgivs,fpknot,fprati,fprota +c +c references: +c dierckx p. : an algorithm for smoothing, differentiation and integ- +c ration of experimental data using spline functions, +c j.comp.appl.maths 1 (1975) 165-184. +c dierckx p. : a fast algorithm for smoothing data on a rectangular +c grid while using spline functions, siam j.numer.anal. +c 19 (1982) 1286-1304. +c dierckx p. : an improved algorithm for curve fitting with spline +c functions, report tw54, dept. computer science,k.u. +c leuven, 1981. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + real*8 xb,xe,s,fp + integer iopt,m,k,nest,n,lwrk,ier +c ..array arguments.. + real*8 x(m),y(m),w(m),t(nest),c(nest),wrk(lwrk) + integer iwrk(nest) +c ..local scalars.. + real*8 tol + integer i,ia,ib,ifp,ig,iq,iz,j,k1,k2,lwest,maxit,nmin +c .. +c we set up the parameters tol and maxit + maxit = 20 + tol = 0.1d-02 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(k.le.0 .or. k.gt.5) go to 50 + k1 = k+1 + k2 = k1+1 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 50 + nmin = 2*k1 + if(m.lt.k1 .or. nest.lt.nmin) go to 50 + lwest = m*k1+nest*(7+3*k) + if(lwrk.lt.lwest) go to 50 + if(xb.gt.x(1) .or. xe.lt.x(m)) go to 50 + do 10 i=2,m + if(x(i-1).gt.x(i)) go to 50 + 10 continue + if(iopt.ge.0) go to 30 + if(n.lt.nmin .or. n.gt.nest) go to 50 + j = n + do 20 i=1,k1 + t(i) = xb + t(j) = xe + j = j-1 + 20 continue + call fpchec(x,m,t,n,k,ier) + if (ier.eq.0) go to 40 + go to 50 + 30 if(s.lt.0.) go to 50 + if(s.eq.0. .and. nest.lt.(m+k1)) go to 50 +c we partition the working space and determine the spline approximation. + 40 ifp = 1 + iz = ifp+nest + ia = iz+nest + ib = ia+nest*k1 + ig = ib+nest*k2 + iq = ig+nest*k2 + call fpcurf(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2,n,t,c,fp, + * wrk(ifp),wrk(iz),wrk(ia),wrk(ib),wrk(ig),wrk(iq),iwrk,ier) + 50 return + end diff --git a/fitpack/dblint.f b/fitpack/dblint.f new file mode 100644 index 0000000..8ae6b17 --- /dev/null +++ b/fitpack/dblint.f @@ -0,0 +1,91 @@ + recursive function dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb, + * ye,wrk) result(dblint_res) + implicit none + real*8 :: dblint_res +c function dblint calculates the double integral +c / xe / ye +c | | s(x,y) dx dy +c xb / yb / +c with s(x,y) a bivariate spline of degrees kx and ky, given in the +c b-spline representation. +c +c calling sequence: +c aint = dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb,ye,wrk) +c +c input parameters: +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c xb,xe : real values, containing the boundaries of the integration +c yb,ye domain. s(x,y) is considered to be identically zero out- +c side the rectangle (tx(kx+1),tx(nx-kx))*(ty(ky+1),ty(ny-ky)) +c +c output parameters: +c aint : real , containing the double integral of s(x,y). +c wrk : real array of dimension at least (nx+ny-kx-ky-2). +c used as working space. +c on exit, wrk(i) will contain the integral +c / xe +c | ni,kx+1(x) dx , i=1,2,...,nx-kx-1 +c xb / +c with ni,kx+1(x) the normalized b-spline defined on +c the knots tx(i),...,tx(i+kx+1) +c wrk(j+nx-kx-1) will contain the integral +c / ye +c | nj,ky+1(y) dy , j=1,2,...,ny-ky-1 +c yb / +c with nj,ky+1(y) the normalized b-spline defined on +c the knots ty(j),...,ty(j+ky+1) +c +c other subroutines required: fpintb +c +c references : +c gaffney p.w. : the calculation of indefinite integrals of b-splines +c j. inst. maths applics 17 (1976) 37-41. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1989 +c +c ..scalar arguments.. + integer nx,ny,kx,ky + real*8 xb,xe,yb,ye +c ..array arguments.. + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),wrk(nx+ny-kx-ky-2) +c ..local scalars.. + integer i,j,l,m,nkx1,nky1 + real*8 res +c .. + nkx1 = nx-kx-1 + nky1 = ny-ky-1 +c we calculate the integrals of the normalized b-splines ni,kx+1(x) + call fpintb(tx,nx,wrk,nkx1,xb,xe) +c we calculate the integrals of the normalized b-splines nj,ky+1(y) + call fpintb(ty,ny,wrk(nkx1+1),nky1,yb,ye) +c calculate the integral of s(x,y) + dblint_res = 0. + do 200 i=1,nkx1 + res = wrk(i) + if(res.eq.0.) go to 200 + m = (i-1)*nky1 + l = nkx1 + do 100 j=1,nky1 + m = m+1 + l = l+1 + dblint_res = dblint_res + res*wrk(l)*c(m) + 100 continue + 200 continue + return + end diff --git a/fitpack/evapol.f b/fitpack/evapol.f new file mode 100644 index 0000000..f02569a --- /dev/null +++ b/fitpack/evapol.f @@ -0,0 +1,84 @@ + recursive function evapol(tu,nu,tv,nv,c,rad,x,y) result(e_res) + implicit none + real*8 :: e_res +c function program evacir evaluates the function f(x,y) = s(u,v), +c defined through the transformation +c x = u*rad(v)*cos(v) y = u*rad(v)*sin(v) +c and where s(u,v) is a bicubic spline ( 0<=u<=1 , -pi<=v<=pi ), given +c in its standard b-spline representation. +c +c calling sequence: +c f = evapol(tu,nu,tv,nv,c,rad,x,y) +c +c input parameters: +c tu : real array, length nu, which contains the position of the +c knots in the u-direction. +c nu : integer, giving the total number of knots in the u-direction +c tv : real array, length nv, which contains the position of the +c knots in the v-direction. +c nv : integer, giving the total number of knots in the v-direction +c c : real array, length (nu-4)*(nv-4), which contains the +c b-spline coefficients. +c rad : real function subprogram, defining the boundary of the +c approximation domain. must be declared external in the +c calling (sub)-program +c x,y : real values. +c before entry x and y must be set to the co-ordinates of +c the point where f(x,y) must be evaluated. +c +c output parameter: +c f : real +c on exit f contains the value of f(x,y) +c +c other subroutines required: +c bispev,fpbisp,fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1989 +c +c ..scalar arguments.. + integer nu,nv + real*8 x,y +c ..array arguments.. + real*8 tu(nu),tv(nv),c((nu-4)*(nv-4)) +c ..user specified function + real*8 rad +c ..local scalars.. + integer ier + real*8 u,v,r,f,one,dist +c ..local arrays + real*8 wrk(8) + integer iwrk(2) +c ..function references + real*8 atan2,sqrt +c .. +c calculate the (u,v)-coordinates of the given point. + one = 1 + u = 0. + v = 0. + dist = x**2+y**2 + if(dist.le.0.) go to 10 + v = atan2(y,x) + r = rad(v) + if(r.le.0.) go to 10 + u = sqrt(dist)/r + if(u.gt.one) u = one +c evaluate s(u,v) + 10 call bispev(tu,nu,tv,nv,c,3,3,u,1,v,1,f,wrk,8,iwrk,2,ier) + e_res = f + return + end + diff --git a/fitpack/fourco.f b/fitpack/fourco.f new file mode 100644 index 0000000..fccf8f8 --- /dev/null +++ b/fitpack/fourco.f @@ -0,0 +1,97 @@ + recursive subroutine fourco(t,n,c,alfa,m,ress,resc,wrk1,wrk2,ier) + implicit none +c subroutine fourco calculates the integrals +c /t(n-3) +c ress(i) = ! s(x)*sin(alfa(i)*x) dx and +c t(4)/ +c /t(n-3) +c resc(i) = ! s(x)*cos(alfa(i)*x) dx, i=1,...,m, +c t(4)/ +c where s(x) denotes a cubic spline which is given in its +c b-spline representation. +c +c calling sequence: +c call fourco(t,n,c,alfa,m,ress,resc,wrk1,wrk2,ier) +c +c input parameters: +c t : real array,length n, containing the knots of s(x). +c n : integer, containing the total number of knots. n>=10. +c c : real array,length n, containing the b-spline coefficients. +c alfa : real array,length m, containing the parameters alfa(i). +c m : integer, specifying the number of integrals to be computed. +c wrk1 : real array,length n. used as working space +c wrk2 : real array,length n. used as working space +c +c output parameters: +c ress : real array,length m, containing the integrals ress(i). +c resc : real array,length m, containing the integrals resc(i). +c ier : error flag: +c ier=0 : normal return. +c ier=10: invalid input data (see restrictions). +c +c restrictions: +c n >= 10 +c t(4) < t(5) < ... < t(n-4) < t(n-3). +c t(1) <= t(2) <= t(3) <= t(4). +c t(n-3) <= t(n-2) <= t(n-1) <= t(n). +c +c other subroutines required: fpbfou,fpcsin +c +c references : +c dierckx p. : calculation of fouriercoefficients of discrete +c functions using cubic splines. j. computational +c and applied mathematics 3 (1977) 207-209. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer n,m,ier +c ..array arguments.. + real*8 t(n),c(n),wrk1(n),wrk2(n),alfa(m),ress(m),resc(m) +c ..local scalars.. + integer i,j,n4 + real*8 rs,rc +c .. + n4 = n-4 +c before starting computations a data check is made. in the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(n.lt.10) go to 50 + j = n + do 10 i=1,3 + if(t(i).gt.t(i+1)) go to 50 + if(t(j).lt.t(j-1)) go to 50 + j = j-1 + 10 continue + do 20 i=4,n4 + if(t(i).ge.t(i+1)) go to 50 + 20 continue + ier = 0 +c main loop for the different alfa(i). + do 40 i=1,m +c calculate the integrals +c wrk1(j) = integral(nj,4(x)*sin(alfa*x)) and +c wrk2(j) = integral(nj,4(x)*cos(alfa*x)), j=1,2,...,n-4, +c where nj,4(x) denotes the normalised cubic b-spline defined on the +c knots t(j),t(j+1),...,t(j+4). + call fpbfou(t,n,alfa(i),wrk1,wrk2) +c calculate the integrals ress(i) and resc(i). + rs = 0. + rc = 0. + do 30 j=1,n4 + rs = rs+c(j)*wrk1(j) + rc = rc+c(j)*wrk2(j) + 30 continue + ress(i) = rs + resc(i) = rc + 40 continue + 50 return + end diff --git a/fitpack/fpader.f b/fitpack/fpader.f new file mode 100644 index 0000000..755953a --- /dev/null +++ b/fitpack/fpader.f @@ -0,0 +1,57 @@ + recursive subroutine fpader(t,n,c,k1,x,l,d) +c subroutine fpader calculates the derivatives +c (j-1) +c d(j) = s (x) , j=1,2,...,k1 +c of a spline of order k1 at the point t(l)<=x= 10, t(4) < t(5) < ... < t(n-4) < t(n-3). +c .. +c ..scalar arguments.. + integer n + real*8 par +c ..array arguments.. + real*8 t(n),ress(n),resc(n) +c ..local scalars.. + integer i,ic,ipj,is,j,jj,jp1,jp4,k,li,lj,ll,nmj,nm3,nm7 + real*8 ak,beta,con1,con2,c1,c2,delta,eps,fac,f1,f2,f3,one,quart, + * sign,six,s1,s2,term +c ..local arrays.. + real*8 co(5),si(5),hs(5),hc(5),rs(3),rc(3) +c ..function references.. + real*8 cos,sin,abs +c .. +c initialization. + one = 0.1e+01 + six = 0.6e+01 + eps = 0.1e-07 + quart = 0.25e0 + con1 = 0.5e-01 + con2 = 0.12e+03 + nm3 = n-3 + nm7 = n-7 + if(par.ne.0.) term = six/par + beta = par*t(4) + co(1) = cos(beta) + si(1) = sin(beta) +c calculate the integrals ress(j) and resc(j), j=1,2,3 by setting up +c a divided difference table. + do 30 j=1,3 + jp1 = j+1 + jp4 = j+4 + beta = par*t(jp4) + co(jp1) = cos(beta) + si(jp1) = sin(beta) + call fpcsin(t(4),t(jp4),par,si(1),co(1),si(jp1),co(jp1), + * rs(j),rc(j)) + i = 5-j + hs(i) = 0. + hc(i) = 0. + do 10 jj=1,j + ipj = i+jj + hs(ipj) = rs(jj) + hc(ipj) = rc(jj) + 10 continue + do 20 jj=1,3 + if(i.lt.jj) i = jj + k = 5 + li = jp4 + do 20 ll=i,4 + lj = li-jj + fac = t(li)-t(lj) + hs(k) = (hs(k)-hs(k-1))/fac + hc(k) = (hc(k)-hc(k-1))/fac + k = k-1 + li = li-1 + 20 continue + ress(j) = hs(5)-hs(4) + resc(j) = hc(5)-hc(4) + 30 continue + if(nm7.lt.4) go to 160 +c calculate the integrals ress(j) and resc(j),j=4,5,...,n-7. + do 150 j=4,nm7 + jp4 = j+4 + beta = par*t(jp4) + co(5) = cos(beta) + si(5) = sin(beta) + delta = t(jp4)-t(j) +c the way of computing ress(j) and resc(j) depends on the value of +c beta = par*(t(j+4)-t(j)). + beta = delta*par + if(abs(beta).le.one) go to 60 +c if !beta! > 1 the integrals are calculated by setting up a divided +c difference table. + do 40 k=1,5 + hs(k) = si(k) + hc(k) = co(k) + 40 continue + do 50 jj=1,3 + k = 5 + li = jp4 + do 50 ll=jj,4 + lj = li-jj + fac = par*(t(li)-t(lj)) + hs(k) = (hs(k)-hs(k-1))/fac + hc(k) = (hc(k)-hc(k-1))/fac + k = k-1 + li = li-1 + 50 continue + s2 = (hs(5)-hs(4))*term + c2 = (hc(5)-hc(4))*term + go to 130 +c if !beta! <= 1 the integrals are calculated by evaluating a series +c expansion. + 60 f3 = 0. + do 70 i=1,4 + ipj = i+j + hs(i) = par*(t(ipj)-t(j)) + hc(i) = hs(i) + f3 = f3+hs(i) + 70 continue + f3 = f3*con1 + c1 = quart + s1 = f3 + if(abs(f3).le.eps) go to 120 + sign = one + fac = con2 + k = 5 + is = 0 + do 110 ic=1,20 + k = k+1 + ak = k + fac = fac*ak + f1 = 0. + f3 = 0. + do 80 i=1,4 + f1 = f1+hc(i) + f2 = f1*hs(i) + hc(i) = f2 + f3 = f3+f2 + 80 continue + f3 = f3*six/fac + if(is.eq.0) go to 90 + is = 0 + s1 = s1+f3*sign + go to 100 + 90 sign = -sign + is = 1 + c1 = c1+f3*sign + 100 if(abs(f3).le.eps) go to 120 + 110 continue + 120 s2 = delta*(co(1)*s1+si(1)*c1) + c2 = delta*(co(1)*c1-si(1)*s1) + 130 ress(j) = s2 + resc(j) = c2 + do 140 i=1,4 + co(i) = co(i+1) + si(i) = si(i+1) + 140 continue + 150 continue +c calculate the integrals ress(j) and resc(j),j=n-6,n-5,n-4 by setting +c up a divided difference table. + 160 do 190 j=1,3 + nmj = nm3-j + i = 5-j + call fpcsin(t(nm3),t(nmj),par,si(4),co(4),si(i-1),co(i-1), + * rs(j),rc(j)) + hs(i) = 0. + hc(i) = 0. + do 170 jj=1,j + ipj = i+jj + hc(ipj) = rc(jj) + hs(ipj) = rs(jj) + 170 continue + do 180 jj=1,3 + if(i.lt.jj) i = jj + k = 5 + li = nmj + do 180 ll=i,4 + lj = li+jj + fac = t(lj)-t(li) + hs(k) = (hs(k-1)-hs(k))/fac + hc(k) = (hc(k-1)-hc(k))/fac + k = k-1 + li = li+1 + 180 continue + ress(nmj) = hs(4)-hs(5) + resc(nmj) = hc(4)-hc(5) + 190 continue + return + end diff --git a/fitpack/fpbisp.f b/fitpack/fpbisp.f new file mode 100644 index 0000000..9056988 --- /dev/null +++ b/fitpack/fpbisp.f @@ -0,0 +1,81 @@ + recursive subroutine fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my, + * z,wx,wy,lx,ly) + implicit none +c ..scalar arguments.. + integer nx,ny,kx,ky,mx,my +c ..array arguments.. + integer lx(mx),ly(my) + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my), + * wx(mx,kx+1),wy(my,ky+1) +c ..local scalars.. + integer kx1,ky1,l,l1,l2,m,nkx1,nky1, i, i1, j, j1 + real*8 arg,sp,tb,te +c ..local arrays.. + real*8 h(6) +c ..subroutine references.. +c fpbspl +c .. + kx1 = kx+1 + nkx1 = nx-kx1 + tb = tx(kx1) + te = tx(nkx1+1) + l = kx1 + l1 = l+1 + do 40 i=1,mx + arg = x(i) + if(arg.lt.tb) arg = tb + if(arg.gt.te) arg = te + 10 if(arg.lt.tx(l1) .or. l.eq.nkx1) go to 20 + l = l1 + l1 = l+1 + go to 10 + 20 call fpbspl(tx,nx,kx,arg,l,h) + lx(i) = l-kx1 + do 30 j=1,kx1 + wx(i,j) = h(j) + 30 continue + 40 continue + ky1 = ky+1 + nky1 = ny-ky1 + tb = ty(ky1) + te = ty(nky1+1) + l = ky1 + l1 = l+1 + do 80 i=1,my + arg = y(i) + if(arg.lt.tb) arg = tb + if(arg.gt.te) arg = te + 50 if(arg.lt.ty(l1) .or. l.eq.nky1) go to 60 + l = l1 + l1 = l+1 + go to 50 + 60 call fpbspl(ty,ny,ky,arg,l,h) + ly(i) = l-ky1 + do 70 j=1,ky1 + wy(i,j) = h(j) + 70 continue + 80 continue + m = 0 + do 130 i=1,mx + l = lx(i)*nky1 + do 90 i1=1,kx1 + h(i1) = wx(i,i1) + 90 continue + do 120 j=1,my + l1 = l+ly(j) + sp = 0. + do 110 i1=1,kx1 + l2 = l1 + do 100 j1=1,ky1 + l2 = l2+1 + sp = sp+c(l2)*h(i1)*wy(j,j1) + 100 continue + l1 = l1+nky1 + 110 continue + m = m+1 + z(m) = sp + 120 continue + 130 continue + return + end + diff --git a/fitpack/fpbspl.f b/fitpack/fpbspl.f new file mode 100644 index 0000000..b05a118 --- /dev/null +++ b/fitpack/fpbspl.f @@ -0,0 +1,42 @@ + recursive subroutine fpbspl(t,n,k,x,l,h) +c subroutine fpbspl evaluates the (k+1) non-zero b-splines of +c degree k at t(l) <= x < t(l+1) using the stable recurrence +c relation of de boor and cox. +c Travis Oliphant 2007 +c changed so that weighting of 0 is used when knots with +c multiplicity are present. +c Also, notice that l+k <= n and 1 <= l+1-k +c or else the routine will be accessing memory outside t +c Thus it is imperative that that k <= l <= n-k but this +c is not checked. +c .. +c ..scalar arguments.. + real*8 x + integer n,k,l +c ..array arguments.. + real*8 t(n),h(20) +c ..local scalars.. + real*8 f,one + integer i,j,li,lj +c ..local arrays.. + real*8 hh(19) +c .. + one = 0.1d+01 + h(1) = one + do 20 j=1,k + do 10 i=1,j + hh(i) = h(i) + 10 continue + h(1) = 0.0d0 + do 20 i=1,j + li = l+i + lj = li-j + if (t(li).ne.t(lj)) goto 15 + h(i+1) = 0.0d0 + goto 20 + 15 f = hh(i)/(t(li)-t(lj)) + h(i) = h(i)+f*(t(li)-x) + h(i+1) = f*(x-t(lj)) + 20 continue + return + end diff --git a/fitpack/fpchec.f b/fitpack/fpchec.f new file mode 100644 index 0000000..215f38f --- /dev/null +++ b/fitpack/fpchec.f @@ -0,0 +1,87 @@ + recursive subroutine fpchec(x,m,t,n,k,ier) + implicit none +c subroutine fpchec verifies the number and the position of the knots +c t(j),j=1,2,...,n of a spline of degree k, in relation to the number +c and the position of the data points x(i),i=1,2,...,m. if all of the +c following conditions are fulfilled, the error parameter ier is set +c to zero. if one of the conditions is violated ier is set to ten. +c 1) k+1 <= n-k-1 <= m +c 2) t(1) <= t(2) <= ... <= t(k+1) +c t(n-k) <= t(n-k+1) <= ... <= t(n) +c 3) t(k+1) < t(k+2) < ... < t(n-k) +c 4) t(k+1) <= x(i) <= t(n-k) +c 5) the conditions specified by schoenberg and whitney must hold +c for at least one subset of data points, i.e. there must be a +c subset of data points y(j) such that +c t(j) < y(j) < t(j+k+1), j=1,2,...,n-k-1 +c .. +c ..scalar arguments.. + integer m,n,k,ier +c ..array arguments.. + real*8 x(m),t(n) +c ..local scalars.. + integer i,j,k1,k2,l,nk1,nk2,nk3 + real*8 tj,tl +c .. + k1 = k+1 + k2 = k1+1 + nk1 = n-k1 + nk2 = nk1+1 + ier = 10 +c check condition no 1 + if (nk1.lt.k1 .or. nk1.gt.m) then + ier = 10 + go to 80 + endif +c check condition no 2 + j = n + do 20 i=1,k + if (t(i) .gt. t(i+1)) then + ier = 20 + go to 80 + endif + if (t(j) .lt. t(j-1)) then + ier = 20 + go to 80 + endif + j = j-1 + 20 continue +c check condition no 3 + do 30 i=k2,nk2 + if (t(i) .le. t(i-1)) then + ier = 30 + go to 80 + endif + 30 continue +c check condition no 4 + if (x(1).lt.t(k1) .or. x(m).gt.t(nk2)) then + ier = 40 + go to 80 + endif +c check condition no 5 + if (x(1).ge.t(k2) .or. x(m).le.t(nk1)) then + ier = 50 + go to 80 + endif + i = 1 + l = k2 + nk3 = nk1-1 + if (nk3 .lt. 2) go to 70 + do 60 j=2,nk3 + tj = t(j) + l = l+1 + tl = t(l) + 40 i = i+1 + if (i .ge. m) then + ier = 50 + go to 80 + endif + if (x(i) .le. tj) go to 40 + if (x(i) .ge. tl) then + ier = 50 + go to 80 + endif + 60 continue + 70 ier = 0 + 80 return + end diff --git a/fitpack/fpched.f b/fitpack/fpched.f new file mode 100644 index 0000000..05e83dc --- /dev/null +++ b/fitpack/fpched.f @@ -0,0 +1,70 @@ + recursive subroutine fpched(x,m,t,n,k,ib,ie,ier) + implicit none +c subroutine fpched verifies the number and the position of the knots +c t(j),j=1,2,...,n of a spline of degree k,with ib derative constraints +c at x(1) and ie constraints at x(m), in relation to the number and +c the position of the data points x(i),i=1,2,...,m. if all of the +c following conditions are fulfilled, the error parameter ier is set +c to zero. if one of the conditions is violated ier is set to ten. +c 1) k+1 <= n-k-1 <= m + max(0,ib-1) + max(0,ie-1) +c 2) t(1) <= t(2) <= ... <= t(k+1) +c t(n-k) <= t(n-k+1) <= ... <= t(n) +c 3) t(k+1) < t(k+2) < ... < t(n-k) +c 4) t(k+1) <= x(i) <= t(n-k) +c 5) the conditions specified by schoenberg and whitney must hold +c for at least one subset of data points, i.e. there must be a +c subset of data points y(j) such that +c t(j) < y(j) < t(j+k+1), j=1+ib1,2+ib1,...,n-k-1-ie1 +c with ib1 = max(0,ib-1), ie1 = max(0,ie-1) +c .. +c ..scalar arguments.. + integer m,n,k,ib,ie,ier +c ..array arguments.. + real*8 x(m),t(n) +c ..local scalars.. + integer i,ib1,ie1,j,jj,k1,k2,l,nk1,nk2,nk3 + real*8 tj,tl +c .. + k1 = k+1 + k2 = k1+1 + nk1 = n-k1 + nk2 = nk1+1 + ib1 = ib-1 + if(ib1.lt.0) ib1 = 0 + ie1 = ie-1 + if(ie1.lt.0) ie1 = 0 + ier = 10 +c check condition no 1 + if(nk1.lt.k1 .or. nk1.gt.(m+ib1+ie1)) go to 80 +c check condition no 2 + j = n + do 20 i=1,k + if(t(i).gt.t(i+1)) go to 80 + if(t(j).lt.t(j-1)) go to 80 + j = j-1 + 20 continue +c check condition no 3 + do 30 i=k2,nk2 + if(t(i).le.t(i-1)) go to 80 + 30 continue +c check condition no 4 + if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 80 +c check condition no 5 + if(x(1).ge.t(k2) .or. x(m).le.t(nk1)) go to 80 + i = 1 + jj = 2+ib1 + l = jj+k + nk3 = nk1-1-ie1 + if(nk3.lt.jj) go to 70 + do 60 j=jj,nk3 + tj = t(j) + l = l+1 + tl = t(l) + 40 i = i+1 + if(i.ge.m) go to 80 + if(x(i).le.tj) go to 40 + if(x(i).ge.tl) go to 80 + 60 continue + 70 ier = 0 + 80 return + end diff --git a/fitpack/fpchep.f b/fitpack/fpchep.f new file mode 100644 index 0000000..9bd4ed6 --- /dev/null +++ b/fitpack/fpchep.f @@ -0,0 +1,82 @@ + recursive subroutine fpchep(x,m,t,n,k,ier) + implicit none +c subroutine fpchep verifies the number and the position of the knots +c t(j),j=1,2,...,n of a periodic spline of degree k, in relation to +c the number and the position of the data points x(i),i=1,2,...,m. +c if all of the following conditions are fulfilled, ier is set +c to zero. if one of the conditions is violated ier is set to ten. +c 1) k+1 <= n-k-1 <= m+k-1 +c 2) t(1) <= t(2) <= ... <= t(k+1) +c t(n-k) <= t(n-k+1) <= ... <= t(n) +c 3) t(k+1) < t(k+2) < ... < t(n-k) +c 4) t(k+1) <= x(i) <= t(n-k) +c 5) the conditions specified by schoenberg and whitney must hold +c for at least one subset of data points, i.e. there must be a +c subset of data points y(j) such that +c t(j) < y(j) < t(j+k+1), j=k+1,...,n-k-1 +c .. +c ..scalar arguments.. + integer m,n,k,ier +c ..array arguments.. + real*8 x(m),t(n) +c ..local scalars.. + integer i,i1,i2,j,j1,k1,k2,l,l1,l2,mm,m1,nk1,nk2 + real*8 per,tj,tl,xi +c .. + k1 = k+1 + k2 = k1+1 + nk1 = n-k1 + nk2 = nk1+1 + m1 = m-1 + ier = 10 +c check condition no 1 + if(nk1.lt.k1 .or. n.gt.m+2*k) go to 130 +c check condition no 2 + j = n + do 20 i=1,k + if(t(i).gt.t(i+1)) go to 130 + if(t(j).lt.t(j-1)) go to 130 + j = j-1 + 20 continue +c check condition no 3 + do 30 i=k2,nk2 + if(t(i).le.t(i-1)) go to 130 + 30 continue +c check condition no 4 + if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 130 +c check condition no 5 + l1 = k1 + l2 = 1 + do 50 l=1,m + xi = x(l) + 40 if(xi.lt.t(l1+1) .or. l.eq.nk1) go to 50 + l1 = l1+1 + l2 = l2+1 + if(l2.gt.k1) go to 60 + go to 40 + 50 continue + l = m + 60 per = t(nk2)-t(k1) + do 120 i1=2,l + i = i1-1 + mm = i+m1 + do 110 j=k1,nk1 + tj = t(j) + j1 = j+k1 + tl = t(j1) + 70 i = i+1 + if(i.gt.mm) go to 120 + i2 = i-m1 + if (i2.le.0) go to 80 + go to 90 + 80 xi = x(i) + go to 100 + 90 xi = x(i2)+per + 100 if(xi.le.tj) go to 70 + if(xi.ge.tl) go to 120 + 110 continue + ier = 0 + go to 130 + 120 continue + 130 return + end diff --git a/fitpack/fpclos.f b/fitpack/fpclos.f new file mode 100644 index 0000000..255534e --- /dev/null +++ b/fitpack/fpclos.f @@ -0,0 +1,715 @@ + recursive subroutine fpclos(iopt,idim,m,u,mx,x,w,k,s,nest,tol, + * maxit,k1,k2,n,t,nc,c,fp,fpint,z,a1,a2,b,g1,g2,q,nrdata,ier) + implicit none +c .. +c ..scalar arguments.. + real*8 s,tol,fp + integer iopt,idim,m,mx,k,nest,maxit,k1,k2,n,nc,ier +c ..array arguments.. + real*8 u(m),x(mx),w(m),t(nest),c(nc),fpint(nest),z(nc),a1(nest,k1) + *, + * a2(nest,k),b(nest,k2),g1(nest,k2),g2(nest,k1),q(m,k1) + integer nrdata(nest) +c ..local scalars.. + real*8 acc,cos,d1,fac,fpart,fpms,fpold,fp0,f1,f2,f3,p,per,pinv,piv + *, + * p1,p2,p3,sin,store,term,ui,wi,rn,one,con1,con4,con9,half + integer i,ich1,ich3,ij,ik,it,iter,i1,i2,i3,j,jj,jk,jper,j1,j2,kk, + * kk1,k3,l,l0,l1,l5,mm,m1,new,nk1,nk2,nmax,nmin,nplus,npl1, + * nrint,n10,n11,n7,n8 +c ..local arrays.. + real*8 h(6),h1(7),h2(6),xi(10) +c ..function references.. + real*8 abs,fprati + integer max0,min0 +c ..subroutine references.. +c fpbacp,fpbspl,fpgivs,fpdisc,fpknot,fprota +c .. +c set constants + one = 0.1e+01 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 + half = 0.5e0 +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 closed curve c +c sinf(u). if the sum f(p=inf) <= s we accept the choice of knots. c +c if iopt=-1 sinf(u) is the requested curve 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 curve until finally fp<=s. c +c the initial choice of knots depends on the value of s and iopt. c +c if s=0 we have spline interpolation; in that case the number of c +c knots equals nmax = m+2*k. c +c if s > 0 and c +c iopt=0 we first compute the least-squares polynomial curve of c +c degree k; n = nmin = 2*k+2. since s(u) must be periodic we c +c find that s(u) reduces to a fixed point. c +c iopt=1 we start with the set of knots found at the last c +c call of the routine, except for the case that s > fp0; then c +c we compute directly the least-squares polynomial curve. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + m1 = m-1 + kk = k + kk1 = k1 + k3 = 3*k+1 + nmin = 2*k1 +c determine the length of the period of the splines. + per = u(m)-u(1) + if(iopt.lt.0) go to 50 +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s +c determine nmax, the number of knots for periodic spline interpolation + nmax = m+2*k + if(s.gt.0. .or. nmax.eq.nmin) go to 30 +c if s=0, s(u) is an interpolating curve. + n = nmax +c test whether the required storage space exceeds the available one. + if(n.gt.nest) go to 620 +c find the position of the interior knots in case of interpolation. + 5 if((k/2)*2 .eq.k) go to 20 + do 10 i=2,m1 + j = i+k + t(j) = u(i) + 10 continue + if(s.gt.0.) go to 50 + kk = k-1 + kk1 = k + if(kk.gt.0) go to 50 + t(1) = t(m)-per + t(2) = u(1) + t(m+1) = u(m) + t(m+2) = t(3)+per + jj = 0 + do 15 i=1,m1 + j = i + do 12 j1=1,idim + jj = jj+1 + c(j) = x(jj) + j = j+n + 12 continue + 15 continue + jj = 1 + j = m + do 17 j1=1,idim + c(j) = c(jj) + j = j+n + jj = jj+n + 17 continue + fp = 0. + fpint(n) = fp0 + fpint(n-1) = 0. + nrdata(n) = 0 + go to 630 + 20 do 25 i=2,m1 + j = i+k + t(j) = (u(i)+u(i-1))*half + 25 continue + go to 50 +c if s > 0 our initial choice depends on the value of iopt. +c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +c polynomial curve. (i.e. a constant point). +c if iopt=1 and fp0>s we start computing the least-squares closed +c curve according the set of knots found at the last call of the +c routine. + 30 if(iopt.eq.0) go to 35 + if(n.eq.nmin) go to 35 + fp0 = fpint(n) + fpold = fpint(n-1) + nplus = nrdata(n) + if(fp0.gt.s) go to 50 +c the case that s(u) is a fixed point is treated separetely. +c fp0 denotes the corresponding sum of squared residuals. + 35 fp0 = 0. + d1 = 0. + do 37 j=1,idim + z(j) = 0. + 37 continue + jj = 0 + do 45 it=1,m1 + wi = w(it) + call fpgivs(wi,d1,cos,sin) + do 40 j=1,idim + jj = jj+1 + fac = wi*x(jj) + call fprota(cos,sin,fac,z(j)) + fp0 = fp0+fac**2 + 40 continue + 45 continue + do 47 j=1,idim + z(j) = z(j)/d1 + 47 continue +c test whether that fixed point is a solution of our problem. + fpms = fp0-s + if(fpms.lt.acc .or. nmax.eq.nmin) go to 640 + fpold = fp0 +c test whether the required storage space exceeds the available one. + if(n.ge.nest) go to 620 +c start computing the least-squares closed curve with one +c interior knot. + nplus = 1 + n = nmin+1 + mm = (m+1)/2 + t(k2) = u(mm) + nrdata(1) = mm-2 + nrdata(2) = m1-mm +c main loop for the different sets of knots. m is a save upper +c bound for the number of trials. + 50 do 340 iter=1,m +c find nrint, the number of knot intervals. + nrint = n-nmin+1 +c find the position of the additional knots which are needed for +c the b-spline representation of s(u). if we take +c t(k+1) = u(1), t(n-k) = u(m) +c t(k+1-j) = t(n-k-j) - per, j=1,2,...k +c t(n-k+j) = t(k+1+j) + per, j=1,2,...k +c then s(u) will be a smooth closed curve if the b-spline +c coefficients satisfy the following conditions +c c((i-1)*n+n7+j) = c((i-1)*n+j), j=1,...k,i=1,2,...,idim (**) +c with n7=n-2*k-1. + t(k1) = u(1) + nk1 = n-k1 + nk2 = nk1+1 + t(nk2) = u(m) + do 60 j=1,k + i1 = nk2+j + i2 = nk2-j + j1 = k1+j + j2 = k1-j + t(i1) = t(j1)+per + t(j2) = t(i2)-per + 60 continue +c compute the b-spline coefficients of the least-squares closed curve +c sinf(u). the observation matrix a is built up row by row while +c taking into account condition (**) and is reduced to triangular +c form by givens transformations . +c at the same time fp=f(p=inf) is computed. +c the n7 x n7 triangularised upper matrix a has the form +c ! a1 ' ! +c a = ! ' a2 ! +c ! 0 ' ! +c with a2 a n7 x k matrix and a1 a n10 x n10 upper triangular +c matrix of bandwidth k+1 ( n10 = n7-k). +c initialization. + do 65 i=1,nc + z(i) = 0. + 65 continue + do 70 i=1,nk1 + do 70 j=1,kk1 + a1(i,j) = 0. + 70 continue + n7 = nk1-k + n10 = n7-kk + jper = 0 + fp = 0. + l = k1 + jj = 0 + do 290 it=1,m1 +c fetch the current data point u(it),x(it) + ui = u(it) + wi = w(it) + do 75 j=1,idim + jj = jj+1 + xi(j) = x(jj)*wi + 75 continue +c search for knot interval t(l) <= ui < t(l+1). + 80 if(ui.lt.t(l+1)) go to 85 + l = l+1 + go to 80 +c evaluate the (k+1) non-zero b-splines at ui and store them in q. + 85 call fpbspl(t,n,k,ui,l,h) + do 90 i=1,k1 + q(it,i) = h(i) + h(i) = h(i)*wi + 90 continue + l5 = l-k1 +c test whether the b-splines nj,k+1(u),j=1+n7,...nk1 are all zero at ui + if(l5.lt.n10) go to 285 + if(jper.ne.0) go to 160 +c initialize the matrix a2. + do 95 i=1,n7 + do 95 j=1,kk + a2(i,j) = 0. + 95 continue + jk = n10+1 + do 110 i=1,kk + ik = jk + do 100 j=1,kk1 + if(ik.le.0) go to 105 + a2(ik,i) = a1(ik,j) + ik = ik-1 + 100 continue + 105 jk = jk+1 + 110 continue + jper = 1 +c if one of the b-splines nj,k+1(u),j=n7+1,...nk1 is not zero at ui +c we take account of condition (**) for setting up the new row +c of the observation matrix a. this row is stored in the arrays h1 +c (the part with respect to a1) and h2 (the part with +c respect to a2). + 160 do 170 i=1,kk + h1(i) = 0. + h2(i) = 0. + 170 continue + h1(kk1) = 0. + j = l5-n10 + do 210 i=1,kk1 + j = j+1 + l0 = j + 180 l1 = l0-kk + if(l1.le.0) go to 200 + if(l1.le.n10) go to 190 + l0 = l1-n10 + go to 180 + 190 h1(l1) = h(i) + go to 210 + 200 h2(l0) = h2(l0)+h(i) + 210 continue +c rotate the new row of the observation matrix into triangle +c by givens transformations. + if(n10.le.0) go to 250 +c rotation with the rows 1,2,...n10 of matrix a. + do 240 j=1,n10 + piv = h1(1) + if(piv.ne.0.) go to 214 + do 212 i=1,kk + h1(i) = h1(i+1) + 212 continue + h1(kk1) = 0. + go to 240 +c calculate the parameters of the givens transformation. + 214 call fpgivs(piv,a1(j,1),cos,sin) +c transformation to the right hand side. + j1 = j + do 217 j2=1,idim + call fprota(cos,sin,xi(j2),z(j1)) + j1 = j1+n + 217 continue +c transformations to the left hand side with respect to a2. + do 220 i=1,kk + call fprota(cos,sin,h2(i),a2(j,i)) + 220 continue + if(j.eq.n10) go to 250 + i2 = min0(n10-j,kk) +c transformations to the left hand side with respect to a1. + do 230 i=1,i2 + i1 = i+1 + call fprota(cos,sin,h1(i1),a1(j,i1)) + h1(i) = h1(i1) + 230 continue + h1(i1) = 0. + 240 continue +c rotation with the rows n10+1,...n7 of matrix a. + 250 do 270 j=1,kk + ij = n10+j + if(ij.le.0) go to 270 + piv = h2(j) + if(piv.eq.0.) go to 270 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a2(ij,j),cos,sin) +c transformations to right hand side. + j1 = ij + do 255 j2=1,idim + call fprota(cos,sin,xi(j2),z(j1)) + j1 = j1+n + 255 continue + if(j.eq.kk) go to 280 + j1 = j+1 +c transformations to left hand side. + do 260 i=j1,kk + call fprota(cos,sin,h2(i),a2(ij,i)) + 260 continue + 270 continue +c add contribution of this row to the sum of squares of residual +c right hand sides. + 280 do 282 j2=1,idim + fp = fp+xi(j2)**2 + 282 continue + go to 290 +c rotation of the new row of the observation matrix into +c triangle in case the b-splines nj,k+1(u),j=n7+1,...n-k-1 are all zero +c at ui. + 285 j = l5 + do 140 i=1,kk1 + j = j+1 + piv = h(i) + if(piv.eq.0.) go to 140 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a1(j,1),cos,sin) +c transformations to right hand side. + j1 = j + do 125 j2=1,idim + call fprota(cos,sin,xi(j2),z(j1)) + j1 = j1+n + 125 continue + if(i.eq.kk1) go to 150 + i2 = 1 + i3 = i+1 +c transformations to left hand side. + do 130 i1=i3,kk1 + i2 = i2+1 + call fprota(cos,sin,h(i1),a1(j,i2)) + 130 continue + 140 continue +c add contribution of this row to the sum of squares of residual +c right hand sides. + 150 do 155 j2=1,idim + fp = fp+xi(j2)**2 + 155 continue + 290 continue + fpint(n) = fp0 + fpint(n-1) = fpold + nrdata(n) = nplus +c backward substitution to obtain the b-spline coefficients . + j1 = 1 + do 292 j2=1,idim + call fpbacp(a1,a2,z(j1),n7,kk,c(j1),kk1,nest) + j1 = j1+n + 292 continue +c calculate from condition (**) the remaining coefficients. + do 297 i=1,k + j1 = i + do 295 j=1,idim + j2 = j1+n7 + c(j2) = c(j1) + j1 = j1+n + 295 continue + 297 continue + if(iopt.lt.0) go to 660 +c test whether the approximation sinf(u) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 660 +c if f(p=inf) < s accept the choice of knots. + if(fpms.lt.0.) go to 350 +c if n=nmax, sinf(u) is an interpolating curve. + if(n.eq.nmax) go to 630 +c increase the number of knots. +c if n=nest we cannot increase the number of knots because of the +c storage capacity limitation. + if(n.eq.nest) go to 620 +c determine the number of knots nplus we are going to add. + npl1 = nplus*2 + rn = nplus + if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) + nplus = min0(nplus*2,max0(npl1,nplus/2,1)) + fpold = fp +c compute the sum of squared residuals for each knot interval +c t(j+k) <= ui <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. + fpart = 0. + i = 1 + l = k1 + jj = 0 + do 320 it=1,m1 + if(u(it).lt.t(l)) go to 300 + new = 1 + l = l+1 + 300 term = 0. + l0 = l-k2 + do 310 j2=1,idim + fac = 0. + j1 = l0 + do 305 j=1,k1 + j1 = j1+1 + fac = fac+c(j1)*q(it,j) + 305 continue + jj = jj+1 + term = term+(w(it)*(fac-x(jj)))**2 + l0 = l0+n + 310 continue + fpart = fpart+term + if(new.eq.0) go to 320 + if(l.gt.k2) go to 315 + fpint(nrint) = term + new = 0 + go to 320 + 315 store = term*half + fpint(i) = fpart-store + i = i+1 + fpart = store + new = 0 + 320 continue + fpint(nrint) = fpint(nrint)+fpart + do 330 l=1,nplus +c add a new knot + call fpknot(u,m,t,n,fpint,nrdata,nrint,nest,1) +c if n=nmax we locate the knots as for interpolation + if(n.eq.nmax) go to 5 +c test whether we cannot further increase the number of knots. + if(n.eq.nest) go to 340 + 330 continue +c restart the computations with the new set of knots. + 340 continue +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing closed curve sp(u). c +c ********************************************************** c +c we have determined the number of knots and their position. c +c we now compute the b-spline coefficients of the smoothing curve c +c sp(u). the observation matrix a is extended by the rows of matrix c +c b expressing that the kth derivative discontinuities of sp(u) at c +c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c +c ponding weights of these additional rows are set to 1/p. c +c iteratively we then have to determine the value of p such that f(p),c +c the sum of squared residuals be = s. we already know that the least-c +c squares polynomial curve corresponds to p=0, and that the least- c +c squares periodic spline curve corresponds to p=infinity. the c +c iteration process which is proposed here, makes use of rational c +c interpolation. since f(p) is a convex and strictly decreasing c +c function of p, it can be approximated by a rational function c +c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c +c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c +c to calculate the new value of p such that r(p)=s. convergence is c +c guaranteed by taking f1>0 and f3<0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c evaluate the discontinuity jump of the kth derivative of the +c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. + 350 call fpdisc(t,n,k2,b,nest) +c initial value for p. + p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + n11 = n10-1 + n8 = n7-1 + p = 0. + l = n7 + do 352 i=1,k + j = k+1-i + p = p+a2(l,j) + l = l-1 + if(l.eq.0) go to 356 + 352 continue + do 354 i=1,n10 + p = p+a1(i,1) + 354 continue + 356 rn = n7 + p = rn/p + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p) = s. + do 595 iter=1,maxit +c form the matrix g as the matrix a extended by the rows of matrix b. +c the rows of matrix b with weight 1/p are rotated into +c the triangularised observation matrix a. +c after triangularisation our n7 x n7 matrix g takes the form +c ! g1 ' ! +c g = ! ' g2 ! +c ! 0 ' ! +c with g2 a n7 x (k+1) matrix and g1 a n11 x n11 upper triangular +c matrix of bandwidth k+2. ( n11 = n7-k-1) + pinv = one/p +c store matrix a into g + do 358 i=1,nc + c(i) = z(i) + 358 continue + do 360 i=1,n7 + g1(i,k1) = a1(i,k1) + g1(i,k2) = 0. + g2(i,1) = 0. + do 360 j=1,k + g1(i,j) = a1(i,j) + g2(i,j+1) = a2(i,j) + 360 continue + l = n10 + do 370 j=1,k1 + if(l.le.0) go to 375 + g2(l,1) = a1(l,j) + l = l-1 + 370 continue + 375 do 540 it=1,n8 +c fetch a new row of matrix b and store it in the arrays h1 (the part +c with respect to g1) and h2 (the part with respect to g2). + do 380 j=1,idim + xi(j) = 0. + 380 continue + do 385 i=1,k1 + h1(i) = 0. + h2(i) = 0. + 385 continue + h1(k2) = 0. + if(it.gt.n11) go to 420 + l = it + l0 = it + do 390 j=1,k2 + if(l0.eq.n10) go to 400 + h1(j) = b(it,j)*pinv + l0 = l0+1 + 390 continue + go to 470 + 400 l0 = 1 + do 410 l1=j,k2 + h2(l0) = b(it,l1)*pinv + l0 = l0+1 + 410 continue + go to 470 + 420 l = 1 + i = it-n10 + do 460 j=1,k2 + i = i+1 + l0 = i + 430 l1 = l0-k1 + if(l1.le.0) go to 450 + if(l1.le.n11) go to 440 + l0 = l1-n11 + go to 430 + 440 h1(l1) = b(it,j)*pinv + go to 460 + 450 h2(l0) = h2(l0)+b(it,j)*pinv + 460 continue + if(n11.le.0) go to 510 +c rotate this row into triangle by givens transformations +c rotation with the rows l,l+1,...n11. + 470 do 500 j=l,n11 + piv = h1(1) +c calculate the parameters of the givens transformation. + call fpgivs(piv,g1(j,1),cos,sin) +c transformation to right hand side. + j1 = j + do 475 j2=1,idim + call fprota(cos,sin,xi(j2),c(j1)) + j1 = j1+n + 475 continue +c transformation to the left hand side with respect to g2. + do 480 i=1,k1 + call fprota(cos,sin,h2(i),g2(j,i)) + 480 continue + if(j.eq.n11) go to 510 + i2 = min0(n11-j,k1) +c transformation to the left hand side with respect to g1. + do 490 i=1,i2 + i1 = i+1 + call fprota(cos,sin,h1(i1),g1(j,i1)) + h1(i) = h1(i1) + 490 continue + h1(i1) = 0. + 500 continue +c rotation with the rows n11+1,...n7 + 510 do 530 j=1,k1 + ij = n11+j + if(ij.le.0) go to 530 + piv = h2(j) +c calculate the parameters of the givens transformation + call fpgivs(piv,g2(ij,j),cos,sin) +c transformation to the right hand side. + j1 = ij + do 515 j2=1,idim + call fprota(cos,sin,xi(j2),c(j1)) + j1 = j1+n + 515 continue + if(j.eq.k1) go to 540 + j1 = j+1 +c transformation to the left hand side. + do 520 i=j1,k1 + call fprota(cos,sin,h2(i),g2(ij,i)) + 520 continue + 530 continue + 540 continue +c backward substitution to obtain the b-spline coefficients + j1 = 1 + do 542 j2=1,idim + call fpbacp(g1,g2,c(j1),n7,k1,c(j1),k2,nest) + j1 = j1+n + 542 continue +c calculate from condition (**) the remaining b-spline coefficients. + do 547 i=1,k + j1 = i + do 545 j=1,idim + j2 = j1+n7 + c(j2) = c(j1) + j1 = j1+n + 545 continue + 547 continue +c computation of f(p). + fp = 0. + l = k1 + jj = 0 + do 570 it=1,m1 + if(u(it).lt.t(l)) go to 550 + l = l+1 + 550 l0 = l-k2 + term = 0. + do 565 j2=1,idim + fac = 0. + j1 = l0 + do 560 j=1,k1 + j1 = j1+1 + fac = fac+c(j1)*q(it,j) + 560 continue + jj = jj+1 + term = term+(fac-x(jj))**2 + l0 = l0+n + 565 continue + fp = fp+term*w(it)**2 + 570 continue +c test whether the approximation sp(u) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 660 +c test whether the maximal number of iterations is reached. + if(iter.eq.maxit) go to 600 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 580 + if((f2-f3) .gt. acc) go to 575 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 +p2*con1 + go to 595 + 575 if(f2.lt.0.) ich3 = 1 + 580 if(ich1.ne.0) go to 590 + if((f1-f2) .gt. acc) go to 585 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 595 + if(p.ge.p3) p = p2*con1 +p3*con9 + go to 595 + 585 if(f2.gt.0.) ich1 = 1 +c test whether the iteration process proceeds as theoretically +c expected. + 590 if(f2.ge.f1 .or. f2.le.f3) go to 610 +c find the new value for p. + p = fprati(p1,f1,p2,f2,p3,f3) + 595 continue +c error codes and messages. + 600 ier = 3 + go to 660 + 610 ier = 2 + go to 660 + 620 ier = 1 + go to 660 + 630 ier = -1 + go to 660 + 640 ier = -2 +c the point (z(1),z(2),...,z(idim)) is a solution of our problem. +c a constant function is a spline of degree k with all b-spline +c coefficients equal to that constant. + do 650 i=1,k1 + rn = k1-i + t(i) = u(1)-rn*per + j = i+k1 + rn = i-1 + t(j) = u(m)+rn*per + 650 continue + n = nmin + j1 = 0 + do 658 j=1,idim + fac = z(j) + j2 = j1 + do 654 i=1,k1 + j2 = j2+1 + c(j2) = fac + 654 continue + j1 = j1+n + 658 continue + fp = fp0 + fpint(n) = fp0 + fpint(n-1) = 0. + nrdata(n) = 0 + 660 return + end diff --git a/fitpack/fpcoco.f b/fitpack/fpcoco.f new file mode 100644 index 0000000..c6a736b --- /dev/null +++ b/fitpack/fpcoco.f @@ -0,0 +1,169 @@ + recursive subroutine fpcoco(iopt,m,x,y,w,v,s,nest,maxtr,maxbin, + * n,t,c,sq,sx,bind,e,wrk,lwrk,iwrk,kwrk,ier) + implicit none +c ..scalar arguments.. + real*8 s,sq + integer iopt,m,nest,maxtr,maxbin,n,lwrk,kwrk,ier +c ..array arguments.. + integer iwrk(kwrk) + real*8 x(m),y(m),w(m),v(m),t(nest),c(nest),sx(m),e(nest),wrk(lwrk) + * + logical bind(nest) +c ..local scalars.. + integer i,ia,ib,ic,iq,iu,iz,izz,i1,j,k,l,l1,m1,nmax,nr,n4,n6,n8, + * ji,jib,jjb,jl,jr,ju,mb,nm + real*8 sql,sqmax,term,tj,xi,half +c ..subroutine references.. +c fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno +c .. +c set constant + half = 0.5e0 +c determine the maximal admissible number of knots. + nmax = m+4 +c the initial choice of knots depends on the value of iopt. +c if iopt=0 the program starts with the minimal number of knots +c so that can be guarantied that the concavity/convexity constraints +c will be satisfied. +c if iopt = 1 the program will continue from the point on where she +c left at the foregoing call. + if(iopt.gt.0) go to 80 +c find the minimal number of knots. +c a knot is located at the data point x(i), i=2,3,...m-1 if +c 1) v(i) ^= 0 and +c 2) v(i)*v(i-1) <= 0 or v(i)*v(i+1) <= 0. + m1 = m-1 + n = 4 + do 20 i=2,m1 + if(v(i).eq.0. .or. (v(i)*v(i-1).gt.0. .and. + * v(i)*v(i+1).gt.0.)) go to 20 + n = n+1 +c test whether the required storage space exceeds the available one. + if(n+4.gt.nest) go to 200 + t(n) = x(i) + 20 continue +c find the position of the knots t(1),...t(4) and t(n-3),...t(n) which +c are needed for the b-spline representation of s(x). + do 30 i=1,4 + t(i) = x(1) + n = n+1 + t(n) = x(m) + 30 continue +c test whether the minimum number of knots exceeds the maximum number. + if(n.gt.nmax) go to 210 +c main loop for the different sets of knots. +c find corresponding values e(j) to the knots t(j+3),j=1,2,...n-6 +c e(j) will take the value -1,1, or 0 according to the requirement +c that s(x) must be locally convex or concave at t(j+3) or that the +c sign of s''(x) is unrestricted at that point. + 40 i= 1 + xi = x(1) + j = 4 + tj = t(4) + n6 = n-6 + do 70 l=1,n6 + 50 if(xi.eq.tj) go to 60 + i = i+1 + xi = x(i) + go to 50 + 60 e(l) = v(i) + j = j+1 + tj = t(j) + 70 continue +c we partition the working space + nm = n+maxbin + mb = maxbin+1 + ia = 1 + ib = ia+4*n + ic = ib+nm*maxbin + iz = ic+n + izz = iz+n + iu = izz+n + iq = iu+maxbin + ji = 1 + ju = ji+maxtr + jl = ju+maxtr + jr = jl+maxtr + jjb = jr+maxtr + jib = jjb+mb +c given the set of knots t(j),j=1,2,...n, find the least-squares cubic +c spline which satisfies the imposed concavity/convexity constraints. + call fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,wrk(ia), + * + * wrk(ib),wrk(ic),wrk(iz),wrk(izz),wrk(iu),wrk(iq),iwrk(ji), + * iwrk(ju),iwrk(jl),iwrk(jr),iwrk(jjb),iwrk(jib),ier) +c if sq <= s or in case of abnormal exit from fpcosp, control is +c repassed to the driver program. + if(sq.le.s .or. ier.gt.0) go to 300 +c calculate for each knot interval t(l-1) <= xi <= t(l) the +c sum((wi*(yi-s(xi)))**2). +c find the interval t(k-1) <= x <= t(k) for which this sum is maximal +c on the condition that this interval contains at least one interior +c data point x(nr) and that s(x) is not given there by a straight line. + 80 sqmax = 0. + sql = 0. + l = 5 + nr = 0 + i1 = 1 + n4 = n-4 + do 110 i=1,m + term = (w(i)*(sx(i)-y(i)))**2 + if(x(i).lt.t(l) .or. l.gt.n4) go to 100 + term = term*half + sql = sql+term + if(i-i1.le.1 .or. (bind(l-4).and.bind(l-3))) go to 90 + if(sql.le.sqmax) go to 90 + k = l + sqmax = sql + nr = i1+(i-i1)/2 + 90 l = l+1 + i1 = i + sql = 0. + 100 sql = sql+term + 110 continue + if(m-i1.le.1 .or. (bind(l-4).and.bind(l-3))) go to 120 + if(sql.le.sqmax) go to 120 + k = l + nr = i1+(m-i1)/2 +c if no such interval is found, control is repassed to the driver +c program (ier = -1). + 120 if(nr.eq.0) go to 190 +c if s(x) is given by the same straight line in two succeeding knot +c intervals t(l-1) <= x <= t(l) and t(l) <= x <= t(l+1),delete t(l) + n8 = n-8 + l1 = 0 + if(n8.le.0) go to 150 + do 140 i=1,n8 + if(.not. (bind(i).and.bind(i+1).and.bind(i+2))) go to 140 + l = i+4-l1 + if(k.gt.l) k = k-1 + n = n-1 + l1 = l1+1 + do 130 j=l,n + t(j) = t(j+1) + 130 continue + 140 continue +c test whether we cannot further increase the number of knots. + 150 if(n.eq.nmax) go to 180 + if(n.eq.nest) go to 170 +c locate an additional knot at the point x(nr). + j = n + do 160 i=k,n + t(j+1) = t(j) + j = j-1 + 160 continue + t(k) = x(nr) + n = n+1 +c restart the computations with the new set of knots. + go to 40 +c error codes and messages. + 170 ier = -3 + go to 300 + 180 ier = -2 + go to 300 + 190 ier = -1 + go to 300 + 200 ier = 4 + go to 300 + 210 ier = 5 + 300 return + end diff --git a/fitpack/fpcons.f b/fitpack/fpcons.f new file mode 100644 index 0000000..843d935 --- /dev/null +++ b/fitpack/fpcons.f @@ -0,0 +1,443 @@ + recursive subroutine fpcons(iopt,idim,m,u,mx,x,w,ib,ie,k,s,nest, + * tol,maxit,k1,k2,n,t,nc,c,fp,fpint,z,a,b,g,q,nrdata,ier) +ccc implicit none c XXX: mmnin/nmin variables on line 61 +c .. +c ..scalar arguments.. + real*8 s,tol,fp + integer iopt,idim,m,mx,ib,ie,k,nest,maxit,k1,k2,n,nc,ier +c ..array arguments.. + real*8 u(m),x(mx),w(m),t(nest),c(nc),fpint(nest), + * z(nc),a(nest,k1),b(nest,k2),g(nest,k2),q(m,k1) + integer nrdata(nest) +c ..local scalars.. + real*8 acc,con1,con4,con9,cos,fac,fpart,fpms,fpold,fp0,f1,f2,f3, + * half,one,p,pinv,piv,p1,p2,p3,rn,sin,store,term,ui,wi + integer i,ich1,ich3,it,iter,i1,i2,i3,j,jb,je,jj,j1,j2,j3,kbe, + * l,li,lj,l0,mb,me,mm,new,nk1,nmax,nmin,nn,nplus,npl1,nrint,n8 +c ..local arrays.. + real*8 h(7),xi(10) +c ..function references + real*8 abs,fprati + integer max0,min0 +c ..subroutine references.. +c fpbacp,fpbspl,fpgivs,fpdisc,fpknot,fprota +c .. +c set constants + one = 0.1e+01 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 + half = 0.5e0 +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 curve sinf(u), c +c and the corresponding sum of squared residuals fp=f(p=inf). c +c if iopt=-1 sinf(u) is the requested curve. 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 curve until finally fp<=s. c +c the initial choice of knots depends on the value of s and iopt. c +c if s=0 we have spline interpolation; in that case the number of c +c knots equals nmax = m+k+1-max(0,ib-1)-max(0,ie-1) c +c if s > 0 and c +c iopt=0 we first compute the least-squares polynomial curve of c +c degree k; n = nmin = 2*k+2 c +c iopt=1 we start with the set of knots found at the last c +c call of the routine, except for the case that s > fp0; then c +c we compute directly the polynomial curve of degree k. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c determine nmin, the number of knots for polynomial approximation. + nmin = 2*k1 +c find which data points are to be considered. + mb = 2 + jb = ib + if(ib.gt.0) go to 10 + mb = 1 + jb = 1 + 10 me = m-1 + je = ie + if(ie.gt.0) go to 20 + me = m + je = 1 + 20 if(iopt.lt.0) go to 60 +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s +c determine nmax, the number of knots for spline interpolation. + kbe = k1-jb-je + mmin = kbe+2 + mm = m-mmin + nmax = nmin+mm + if(s.gt.0.) go to 40 +c if s=0, s(u) is an interpolating curve. +c test whether the required storage space exceeds the available one. + n = nmax + if(nmax.gt.nest) go to 420 +c find the position of the interior knots in case of interpolation. + if(mm.eq.0) go to 60 + 25 i = k2 + j = 3-jb+k/2 + do 30 l=1,mm + t(i) = u(j) + i = i+1 + j = j+1 + 30 continue + go to 60 +c if s>0 our initial choice of knots depends on the value of iopt. +c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +c polynomial curve which is a spline curve without interior knots. +c if iopt=1 and fp0>s we start computing the least squares spline curve +c according to the set of knots found at the last call of the routine. + 40 if(iopt.eq.0) go to 50 + if(n.eq.nmin) go to 50 + fp0 = fpint(n) + fpold = fpint(n-1) + nplus = nrdata(n) + if(fp0.gt.s) go to 60 + 50 n = nmin + fpold = 0. + nplus = 0 + nrdata(1) = m-2 +c main loop for the different sets of knots. m is a save upper bound +c for the number of trials. + 60 do 200 iter = 1,m + if(n.eq.nmin) ier = -2 +c find nrint, tne number of knot intervals. + nrint = n-nmin+1 +c find the position of the additional knots which are needed for +c the b-spline representation of s(u). + nk1 = n-k1 + i = n + do 70 j=1,k1 + t(j) = u(1) + t(i) = u(m) + i = i-1 + 70 continue +c compute the b-spline coefficients of the least-squares spline curve +c sinf(u). the observation matrix a is built up row by row and +c reduced to upper triangular form by givens transformations. +c at the same time fp=f(p=inf) is computed. + fp = 0. +c nn denotes the dimension of the splines + nn = nk1-ib-ie +c initialize the b-spline coefficients and the observation matrix a. + do 75 i=1,nc + z(i) = 0. + c(i) = 0. + 75 continue + if(me.lt.mb) go to 134 + if(nn.eq.0) go to 82 + do 80 i=1,nn + do 80 j=1,k1 + a(i,j) = 0. + 80 continue + 82 l = k1 + jj = (mb-1)*idim + do 130 it=mb,me +c fetch the current data point u(it),x(it). + ui = u(it) + wi = w(it) + do 84 j=1,idim + jj = jj+1 + xi(j) = x(jj)*wi + 84 continue +c search for knot interval t(l) <= ui < t(l+1). + 86 if(ui.lt.t(l+1) .or. l.eq.nk1) go to 90 + l = l+1 + go to 86 +c evaluate the (k+1) non-zero b-splines at ui and store them in q. + 90 call fpbspl(t,n,k,ui,l,h) + do 92 i=1,k1 + q(it,i) = h(i) + h(i) = h(i)*wi + 92 continue +c take into account that certain b-spline coefficients must be zero. + lj = k1 + j = nk1-l-ie + if(j.ge.0) go to 94 + lj = lj+j + 94 li = 1 + j = l-k1-ib + if(j.ge.0) go to 96 + li = li-j + j = 0 + 96 if(li.gt.lj) go to 120 +c rotate the new row of the observation matrix into triangle. + do 110 i=li,lj + j = j+1 + piv = h(i) + if(piv.eq.0.) go to 110 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(j,1),cos,sin) +c transformations to right hand side. + j1 = j + do 98 j2 =1,idim + call fprota(cos,sin,xi(j2),z(j1)) + j1 = j1+n + 98 continue + if(i.eq.lj) go to 120 + i2 = 1 + i3 = i+1 + do 100 i1 = i3,lj + i2 = i2+1 +c transformations to left hand side. + call fprota(cos,sin,h(i1),a(j,i2)) + 100 continue + 110 continue +c add contribution of this row to the sum of squares of residual +c right hand sides. + 120 do 125 j2=1,idim + fp = fp+xi(j2)**2 + 125 continue + 130 continue + if(ier.eq.(-2)) fp0 = fp + fpint(n) = fp0 + fpint(n-1) = fpold + nrdata(n) = nplus +c backward substitution to obtain the b-spline coefficients. + if(nn.eq.0) go to 134 + j1 = 1 + do 132 j2=1,idim + j3 = j1+ib + call fpback(a,z(j1),nn,k1,c(j3),nest) + j1 = j1+n + 132 continue +c test whether the approximation sinf(u) is an acceptable solution. + 134 if(iopt.lt.0) go to 440 + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c if f(p=inf) < s accept the choice of knots. + if(fpms.lt.0.) go to 250 +c if n = nmax, sinf(u) is an interpolating spline curve. + if(n.eq.nmax) go to 430 +c increase the number of knots. +c if n=nest we cannot increase the number of knots because of +c the storage capacity limitation. + if(n.eq.nest) go to 420 +c determine the number of knots nplus we are going to add. + if(ier.eq.0) go to 140 + nplus = 1 + ier = 0 + go to 150 + 140 npl1 = nplus*2 + rn = nplus + if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) + nplus = min0(nplus*2,max0(npl1,nplus/2,1)) + 150 fpold = fp +c compute the sum of squared residuals for each knot interval +c t(j+k) <= u(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. + fpart = 0. + i = 1 + l = k2 + new = 0 + jj = (mb-1)*idim + do 180 it=mb,me + if(u(it).lt.t(l) .or. l.gt.nk1) go to 160 + new = 1 + l = l+1 + 160 term = 0. + l0 = l-k2 + do 175 j2=1,idim + fac = 0. + j1 = l0 + do 170 j=1,k1 + j1 = j1+1 + fac = fac+c(j1)*q(it,j) + 170 continue + jj = jj+1 + term = term+(w(it)*(fac-x(jj)))**2 + l0 = l0+n + 175 continue + fpart = fpart+term + if(new.eq.0) go to 180 + store = term*half + fpint(i) = fpart-store + i = i+1 + fpart = store + new = 0 + 180 continue + fpint(nrint) = fpart + do 190 l=1,nplus +c add a new knot. + call fpknot(u,m,t,n,fpint,nrdata,nrint,nest,1) +c if n=nmax we locate the knots as for interpolation + if(n.eq.nmax) go to 25 +c test whether we cannot further increase the number of knots. + if(n.eq.nest) go to 200 + 190 continue +c restart the computations with the new set of knots. + 200 continue +c test whether the least-squares kth degree polynomial curve is a +c solution of our approximation problem. + 250 if(ier.eq.(-2)) go to 440 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline curve sp(u). c +c ********************************************************** c +c we have determined the number of knots and their position. c +c we now compute the b-spline coefficients of the smoothing curve c +c sp(u). the observation matrix a is extended by the rows of matrix c +c b expressing that the kth derivative discontinuities of sp(u) at c +c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c +c ponding weights of these additional rows are set to 1/p. c +c iteratively we then have to determine the value of p such that f(p),c +c the sum of squared residuals be = s. we already know that the least c +c squares kth degree polynomial curve corresponds to p=0, and that c +c the least-squares spline curve corresponds to p=infinity. the c +c iteration process which is proposed here, makes use of rational c +c interpolation. since f(p) is a convex and strictly decreasing c +c function of p, it can be approximated by a rational function c +c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c +c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c +c to calculate the new value of p such that r(p)=s. convergence is c +c guaranteed by taking f1>0 and f3<0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c evaluate the discontinuity jump of the kth derivative of the +c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. + call fpdisc(t,n,k2,b,nest) +c initial value for p. + p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + p = 0. + do 252 i=1,nn + p = p+a(i,1) + 252 continue + rn = nn + p = rn/p + ich1 = 0 + ich3 = 0 + n8 = n-nmin +c iteration process to find the root of f(p) = s. + do 360 iter=1,maxit +c the rows of matrix b with weight 1/p are rotated into the +c triangularised observation matrix a which is stored in g. + pinv = one/p + do 255 i=1,nc + c(i) = z(i) + 255 continue + do 260 i=1,nn + g(i,k2) = 0. + do 260 j=1,k1 + g(i,j) = a(i,j) + 260 continue + do 300 it=1,n8 +c the row of matrix b is rotated into triangle by givens transformation + do 264 i=1,k2 + h(i) = b(it,i)*pinv + 264 continue + do 268 j=1,idim + xi(j) = 0. + 268 continue +c take into account that certain b-spline coefficients must be zero. + if(it.gt.ib) go to 274 + j1 = ib-it+2 + j2 = 1 + do 270 i=j1,k2 + h(j2) = h(i) + j2 = j2+1 + 270 continue + do 272 i=j2,k2 + h(i) = 0. + 272 continue + 274 jj = max0(1,it-ib) + do 290 j=jj,nn + piv = h(1) +c calculate the parameters of the givens transformation. + call fpgivs(piv,g(j,1),cos,sin) +c transformations to right hand side. + j1 = j + do 277 j2=1,idim + call fprota(cos,sin,xi(j2),c(j1)) + j1 = j1+n + 277 continue + if(j.eq.nn) go to 300 + i2 = min0(nn-j,k1) + do 280 i=1,i2 +c transformations to left hand side. + i1 = i+1 + call fprota(cos,sin,h(i1),g(j,i1)) + h(i) = h(i1) + 280 continue + h(i2+1) = 0. + 290 continue + 300 continue +c backward substitution to obtain the b-spline coefficients. + j1 = 1 + do 308 j2=1,idim + j3 = j1+ib + call fpback(g,c(j1),nn,k2,c(j3),nest) + if(ib.eq.0) go to 306 + j3 = j1 + do 304 i=1,ib + c(j3) = 0. + j3 = j3+1 + 304 continue + 306 j1 =j1+n + 308 continue +c computation of f(p). + fp = 0. + l = k2 + jj = (mb-1)*idim + do 330 it=mb,me + if(u(it).lt.t(l) .or. l.gt.nk1) go to 310 + l = l+1 + 310 l0 = l-k2 + term = 0. + do 325 j2=1,idim + fac = 0. + j1 = l0 + do 320 j=1,k1 + j1 = j1+1 + fac = fac+c(j1)*q(it,j) + 320 continue + jj = jj+1 + term = term+(fac-x(jj))**2 + l0 = l0+n + 325 continue + fp = fp+term*w(it)**2 + 330 continue +c test whether the approximation sp(u) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c test whether the maximal number of iterations is reached. + if(iter.eq.maxit) go to 400 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 340 + if((f2-f3).gt.acc) go to 335 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p=p1*con9 + p2*con1 + go to 360 + 335 if(f2.lt.0.) ich3=1 + 340 if(ich1.ne.0) go to 350 + if((f1-f2).gt.acc) go to 345 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 360 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 360 + 345 if(f2.gt.0.) ich1=1 +c test whether the iteration process proceeds as theoretically +c expected. + 350 if(f2.ge.f1 .or. f2.le.f3) go to 410 +c find the new value for p. + p = fprati(p1,f1,p2,f2,p3,f3) + 360 continue +c error codes and messages. + 400 ier = 3 + go to 440 + 410 ier = 2 + go to 440 + 420 ier = 1 + go to 440 + 430 ier = -1 + 440 return + end diff --git a/fitpack/fpcosp.f b/fitpack/fpcosp.f new file mode 100644 index 0000000..70daf96 --- /dev/null +++ b/fitpack/fpcosp.f @@ -0,0 +1,363 @@ + recursive subroutine fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx, + * bind,nm,mb,a, + * b,const,z,zz,u,q,info,up,left,right,jbind,ibind,ier) + implicit none +c .. +c ..scalar arguments.. + real*8 sq + integer m,n,maxtr,maxbin,nm,mb,ier +c ..array arguments.. + real*8 x(m),y(m),w(m),t(n),e(n),c(n),sx(m),a(n,4),b(nm,maxbin), + * const(n),z(n),zz(n),u(maxbin),q(m,4) + integer info(maxtr),up(maxtr),left(maxtr),right(maxtr),jbind(mb), + * ibind(mb) + logical bind(n) +c ..local scalars.. + integer count,i,i1,j,j1,j2,j3,k,kdim,k1,k2,k3,k4,k5,k6, + * l,lp1,l1,l2,l3,merk,nbind,number,n1,n4,n6 + real*8 f,wi,xi +c ..local array.. + real*8 h(4) +c ..subroutine references.. +c fpbspl,fpadno,fpdeno,fpfrno,fpseno +c .. +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c if we use the b-spline representation of s(x) our approximation c +c problem results in a quadratic programming problem: c +c find the b-spline coefficients c(j),j=1,2,...n-4 such that c +c (1) sumi((wi*(yi-sumj(cj*nj(xi))))**2),i=1,2,...m is minimal c +c (2) sumj(cj*n''j(t(l+3)))*e(l) <= 0, l=1,2,...n-6. c +c to solve this problem we use the theil-van de panne procedure. c +c if the inequality constraints (2) are numbered from 1 to n-6, c +c this algorithm finds a subset of constraints ibind(1)..ibind(nbind) c +c such that the solution of the minimization problem (1) with these c +c constraints in equality form, satisfies all constraints. such a c +c feasible solution is optimal if the lagrange parameters associated c +c with that problem with equality constraints, are all positive. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c determine n6, the number of inequality constraints. + n6 = n-6 +c fix the parameters which determine these constraints. + do 10 i=1,n6 + const(i) = e(i)*(t(i+4)-t(i+1))/(t(i+5)-t(i+2)) + 10 continue +c initialize the triply linked tree which is used to find the subset +c of constraints ibind(1),...ibind(nbind). + count = 1 + info(1) = 0 + left(1) = 0 + right(1) = 0 + up(1) = 1 + merk = 1 +c set up the normal equations n'nc=n'y where n denotes the m x (n-4) +c observation matrix with elements ni,j = wi*nj(xi) and y is the +c column vector with elements yi*wi. +c from the properties of the b-splines nj(x),j=1,2,...n-4, it follows +c that n'n is a (n-4) x (n-4) positive definite bandmatrix of +c bandwidth 7. the matrices n'n and n'y are built up in a and z. + n4 = n-4 +c initialization + do 20 i=1,n4 + z(i) = 0. + do 20 j=1,4 + a(i,j) = 0. + 20 continue + l = 4 + lp1 = l+1 + do 70 i=1,m +c fetch the current row of the observation matrix. + xi = x(i) + wi = w(i)**2 +c search for knot interval t(l) <= xi < t(l+1) + 30 if(xi.lt.t(lp1) .or. l.eq.n4) go to 40 + l = lp1 + lp1 = l+1 + go to 30 +c evaluate the four non-zero cubic b-splines nj(xi),j=l-3,...l. + 40 call fpbspl(t,n,3,xi,l,h) +c store in q these values h(1),h(2),...h(4). + do 50 j=1,4 + q(i,j) = h(j) + 50 continue +c add the contribution of the current row of the observation matrix +c n to the normal equations. + l3 = l-3 + k1 = 0 + do 60 j1 = l3,l + k1 = k1+1 + f = h(k1) + z(j1) = z(j1)+f*wi*y(i) + k2 = k1 + j2 = 4 + do 60 j3 = j1,l + a(j3,j2) = a(j3,j2)+f*wi*h(k2) + k2 = k2+1 + j2 = j2-1 + 60 continue + 70 continue +c since n'n is a symmetric matrix it can be factorized as +c (3) n'n = (r1)'(d1)(r1) +c with d1 a diagonal matrix and r1 an (n-4) x (n-4) unit upper +c triangular matrix of bandwidth 4. the matrices r1 and d1 are built +c up in a. at the same time we solve the systems of equations +c (4) (r1)'(z2) = n'y +c (5) (d1) (z1) = (z2) +c the vectors z2 and z1 are kept in zz and z. + do 140 i=1,n4 + k1 = 1 + if(i.lt.4) k1 = 5-i + k2 = i-4+k1 + k3 = k2 + do 100 j=k1,4 + k4 = j-1 + k5 = 4-j+k1 + f = a(i,j) + if(k1.gt.k4) go to 90 + k6 = k2 + do 80 k=k1,k4 + f = f-a(i,k)*a(k3,k5)*a(k6,4) + k5 = k5+1 + k6 = k6+1 + 80 continue + 90 if(j.eq.4) go to 110 + a(i,j) = f/a(k3,4) + k3 = k3+1 + 100 continue + 110 a(i,4) = f + f = z(i) + if(i.eq.1) go to 130 + k4 = i + do 120 j=k1,3 + k = k1+3-j + k4 = k4-1 + f = f-a(i,k)*z(k4)*a(k4,4) + 120 continue + 130 z(i) = f/a(i,4) + zz(i) = f + 140 continue +c start computing the least-squares cubic spline without taking account +c of any constraint. + nbind = 0 + n1 = 1 + ibind(1) = 0 +c main loop for the least-squares problems with different subsets of +c the constraints (2) in equality form. the resulting b-spline coeff. +c c and lagrange parameters u are the solution of the system +c ! n'n b' ! ! c ! ! n'y ! +c (6) ! ! ! ! = ! ! +c ! b 0 ! ! u ! ! 0 ! +c z1 is stored into array c. + 150 do 160 i=1,n4 + c(i) = z(i) + 160 continue +c if there are no equality constraints, compute the coeff. c directly. + if(nbind.eq.0) go to 370 +c initialization + kdim = n4+nbind + do 170 i=1,nbind + do 170 j=1,kdim + b(j,i) = 0. + 170 continue +c matrix b is built up,expressing that the constraints nrs ibind(1),... +c ibind(nbind) must be satisfied in equality form. + do 180 i=1,nbind + l = ibind(i) + b(l,i) = e(l) + b(l+1,i) = -(e(l)+const(l)) + b(l+2,i) = const(l) + 180 continue +c find the matrix (b1) as the solution of the system of equations +c (7) (r1)'(d1)(b1) = b' +c (b1) is built up in the upper part of the array b(rows 1,...n-4). + do 220 k1=1,nbind + l = ibind(k1) + do 210 i=l,n4 + f = b(i,k1) + if(i.eq.1) go to 200 + k2 = 3 + if(i.lt.4) k2 = i-1 + do 190 k3=1,k2 + l1 = i-k3 + l2 = 4-k3 + f = f-b(l1,k1)*a(i,l2)*a(l1,4) + 190 continue + 200 b(i,k1) = f/a(i,4) + 210 continue + 220 continue +c factorization of the symmetric matrix -(b1)'(d1)(b1) +c (8) -(b1)'(d1)(b1) = (r2)'(d2)(r2) +c with (d2) a diagonal matrix and (r2) an nbind x nbind unit upper +c triangular matrix. the matrices r2 and d2 are built up in the lower +c part of the array b (rows n-3,n-2,...n-4+nbind). + do 270 i=1,nbind + i1 = i-1 + do 260 j=i,nbind + f = 0. + do 230 k=1,n4 + f = f+b(k,i)*b(k,j)*a(k,4) + 230 continue + k1 = n4+1 + if(i1.eq.0) go to 250 + do 240 k=1,i1 + f = f+b(k1,i)*b(k1,j)*b(k1,k) + k1 = k1+1 + 240 continue + 250 b(k1,j) = -f + if(j.eq.i) go to 260 + b(k1,j) = b(k1,j)/b(k1,i) + 260 continue + 270 continue +c according to (3),(7) and (8) the system of equations (6) becomes +c ! (r1)' 0 ! ! (d1) 0 ! ! (r1) (b1) ! ! c ! ! n'y ! +c (9) ! ! ! ! ! ! ! ! = ! ! +c ! (b1)' (r2)'! ! 0 (d2) ! ! 0 (r2) ! ! u ! ! 0 ! +c backward substitution to obtain the b-spline coefficients c(j),j=1,.. +c n-4 and the lagrange parameters u(j),j=1,2,...nbind. +c first step of the backward substitution: solve the system +c ! (r1)'(d1) 0 ! ! (c1) ! ! n'y ! +c (10) ! ! ! ! = ! ! +c ! (b1)'(d1) (r2)'(d2) ! ! (u1) ! ! 0 ! +c from (4) and (5) we know that this is equivalent to +c (11) (c1) = (z1) +c (12) (r2)'(d2)(u1) = -(b1)'(z2) + do 310 i=1,nbind + f = 0. + do 280 j=1,n4 + f = f+b(j,i)*zz(j) + 280 continue + i1 = i-1 + k1 = n4+1 + if(i1.eq.0) go to 300 + do 290 j=1,i1 + f = f+u(j)*b(k1,i)*b(k1,j) + k1 = k1+1 + 290 continue + 300 u(i) = -f/b(k1,i) + 310 continue +c second step of the backward substitution: solve the system +c ! (r1) (b1) ! ! c ! ! c1 ! +c (13) ! ! ! ! = ! ! +c ! 0 (r2) ! ! u ! ! u1 ! + k1 = nbind + k2 = kdim +c find the lagrange parameters u. + do 340 i=1,nbind + f = u(k1) + if(i.eq.1) go to 330 + k3 = k1+1 + do 320 j=k3,nbind + f = f-u(j)*b(k2,j) + 320 continue + 330 u(k1) = f + k1 = k1-1 + k2 = k2-1 + 340 continue +c find the b-spline coefficients c. + do 360 i=1,n4 + f = c(i) + do 350 j=1,nbind + f = f-u(j)*b(i,j) + 350 continue + c(i) = f + 360 continue + 370 k1 = n4 + do 390 i=2,n4 + k1 = k1-1 + f = c(k1) + k2 = 1 + if(i.lt.5) k2 = 5-i + k3 = k1 + l = 3 + do 380 j=k2,3 + k3 = k3+1 + f = f-a(k3,l)*c(k3) + l = l-1 + 380 continue + c(k1) = f + 390 continue +c test whether the solution of the least-squares problem with the +c constraints ibind(1),...ibind(nbind) in equality form, satisfies +c all of the constraints (2). + k = 1 +c number counts the number of violated inequality constraints. + number = 0 + do 440 j=1,n6 + l = ibind(k) + k = k+1 + if(j.eq.l) go to 440 + k = k-1 +c test whether constraint j is satisfied + f = e(j)*(c(j)-c(j+1))+const(j)*(c(j+2)-c(j+1)) + if(f.le.0.) go to 440 +c if constraint j is not satisfied, add a branch of length nbind+1 +c to the tree. the nodes of this branch contain in their information +c field the number of the constraints ibind(1),...ibind(nbind) and j, +c arranged in increasing order. + number = number+1 + k1 = k-1 + if(k1.eq.0) go to 410 + do 400 i=1,k1 + jbind(i) = ibind(i) + 400 continue + 410 jbind(k) = j + if(l.eq.0) go to 430 + do 420 i=k,nbind + jbind(i+1) = ibind(i) + 420 continue + 430 call fpadno(maxtr,up,left,right,info,count,merk,jbind,n1,ier) +c test whether the storage space which is required for the tree,exceeds +c the available storage space. + if(ier.ne.0) go to 560 + 440 continue +c test whether the solution of the least-squares problem with equality +c constraints is a feasible solution. + if(number.eq.0) go to 470 +c test whether there are still cases with nbind constraints in +c equality form to be considered. + 450 if(merk.gt.1) go to 460 + nbind = n1 +c test whether the number of knots where s''(x)=0 exceeds maxbin. + if(nbind.gt.maxbin) go to 550 + n1 = n1+1 + ibind(n1) = 0 +c search which cases with nbind constraints in equality form +c are going to be considered. + call fpdeno(maxtr,up,left,right,nbind,merk) +c test whether the quadratic programming problem has a solution. + if(merk.eq.1) go to 570 +c find a new case with nbind constraints in equality form. + 460 call fpseno(maxtr,up,left,right,info,merk,ibind,nbind) + go to 150 +c test whether the feasible solution is optimal. + 470 ier = 0 + do 480 i=1,n6 + bind(i) = .false. + 480 continue + if(nbind.eq.0) go to 500 + do 490 i=1,nbind + if(u(i).le.0.) go to 450 + j = ibind(i) + bind(j) = .true. + 490 continue +c evaluate s(x) at the data points x(i) and calculate the weighted +c sum of squared residual right hand sides sq. + 500 sq = 0. + l = 4 + lp1 = 5 + do 530 i=1,m + 510 if(x(i).lt.t(lp1) .or. l.eq.n4) go to 520 + l = lp1 + lp1 = l+1 + go to 510 + 520 sx(i) = c(l-3)*q(i,1)+c(l-2)*q(i,2)+c(l-1)*q(i,3)+c(l)*q(i,4) + sq = sq+(w(i)*(y(i)-sx(i)))**2 + 530 continue + go to 600 +c error codes and messages. + 550 ier = 1 + go to 600 + 560 ier = 2 + go to 600 + 570 ier = 3 + 600 return + end diff --git a/fitpack/fpcsin.f b/fitpack/fpcsin.f new file mode 100644 index 0000000..0c50861 --- /dev/null +++ b/fitpack/fpcsin.f @@ -0,0 +1,57 @@ + recursive subroutine fpcsin(a,b,par,sia,coa,sib,cob,ress,resc) + implicit none +c fpcsin calculates the integrals ress=integral((b-x)**3*sin(par*x)) +c and resc=integral((b-x)**3*cos(par*x)) over the interval (a,b), +c given sia=sin(par*a),coa=cos(par*a),sib=sin(par*b) and cob=cos(par*b) +c .. +c ..scalar arguments.. + real*8 a,b,par,sia,coa,sib,cob,ress,resc +c ..local scalars.. + integer i,j + real*8 ab,ab4,ai,alfa,beta,b2,b4,eps,fac,f1,f2,one,quart,six, + * three,two +c ..function references.. + real*8 abs +c .. + one = 0.1e+01 + two = 0.2e+01 + three = 0.3e+01 + six = 0.6e+01 + quart = 0.25e+0 + eps = 0.1e-09 + ab = b-a + ab4 = ab**4 + alfa = ab*par +c the way of calculating the integrals ress and resc depends on +c the value of alfa = (b-a)*par. + if(abs(alfa).le.one) go to 100 +c integration by parts. + beta = one/alfa + b2 = beta**2 + b4 = six*b2**2 + f1 = three*b2*(one-two*b2) + f2 = beta*(one-six*b2) + ress = ab4*(coa*f2+sia*f1+sib*b4) + resc = ab4*(coa*f1-sia*f2+cob*b4) + go to 400 +c ress and resc are found by evaluating a series expansion. + 100 fac = quart + f1 = fac + f2 = 0. + i = 4 + do 200 j=1,5 + i = i+1 + ai = i + fac = fac*alfa/ai + f2 = f2+fac + if(abs(fac).le.eps) go to 300 + i = i+1 + ai = i + fac = -fac*alfa/ai + f1 = f1+fac + if(abs(fac).le.eps) go to 300 + 200 continue + 300 ress = ab4*(coa*f2+sia*f1) + resc = ab4*(coa*f1-sia*f2) + 400 return + end diff --git a/fitpack/fpcurf.f b/fitpack/fpcurf.f new file mode 100644 index 0000000..1afb190 --- /dev/null +++ b/fitpack/fpcurf.f @@ -0,0 +1,360 @@ + recursive subroutine fpcurf(iopt,x,y,w,m,xb,xe,k,s,nest,tol, + * maxit,k1,k2,n,t,c,fp,fpint,z,a,b,g,q,nrdata,ier) + implicit none +c .. +c ..scalar arguments.. + real*8 xb,xe,s,tol,fp + integer iopt,m,k,nest,maxit,k1,k2,n,ier +c ..array arguments.. + real*8 x(m),y(m),w(m),t(nest),c(nest),fpint(nest), + * z(nest),a(nest,k1),b(nest,k2),g(nest,k2),q(m,k1) + integer nrdata(nest) +c ..local scalars.. + real*8 acc,con1,con4,con9,cos,half,fpart,fpms,fpold,fp0,f1,f2,f3, + * one,p,pinv,piv,p1,p2,p3,rn,sin,store,term,wi,xi,yi + integer i,ich1,ich3,it,iter,i1,i2,i3,j,k3,l,l0, + * mk1,new,nk1,nmax,nmin,nplus,npl1,nrint,n8 +c ..local arrays.. + real*8 h(7) +c ..function references + real*8 abs,fprati + integer max0,min0 +c ..subroutine references.. +c fpback,fpbspl,fpgivs,fpdisc,fpknot,fprota +c .. +c set constants + one = 0.1d+01 + con1 = 0.1d0 + con9 = 0.9d0 + con4 = 0.4d-01 + half = 0.5d0 +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), c +c and the corresponding sum of squared residuals fp=f(p=inf). c +c if iopt=-1 sinf(x) 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 s=0 we have spline interpolation; in that case the number of c +c knots equals nmax = m+k+1. c +c if s > 0 and c +c iopt=0 we first compute the least-squares polynomial of c +c degree k; n = nmin = 2*k+2 c +c iopt=1 we start with the set of knots found at the last c +c call of the routine, except for the case that s > fp0; then c +c we compute directly the least-squares polynomial of degree k. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c determine nmin, the number of knots for polynomial approximation. + nmin = 2*k1 + if(iopt.lt.0) go to 60 +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s +c determine nmax, the number of knots for spline interpolation. + nmax = m+k1 + if(s.gt.0.0d0) go to 45 +c if s=0, s(x) is an interpolating spline. +c test whether the required storage space exceeds the available one. + n = nmax + if(nmax.gt.nest) go to 420 +c find the position of the interior knots in case of interpolation. + 10 mk1 = m-k1 + if(mk1.eq.0) go to 60 + k3 = k/2 + i = k2 + j = k3+2 + if(k3*2.eq.k) go to 30 + do 20 l=1,mk1 + t(i) = x(j) + i = i+1 + j = j+1 + 20 continue + go to 60 + 30 do 40 l=1,mk1 + t(i) = (x(j)+x(j-1))*half + i = i+1 + j = j+1 + 40 continue + go to 60 +c if s>0 our initial choice of knots depends on the value of iopt. +c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +c polynomial of degree k which is a spline without interior knots. +c if iopt=1 and fp0>s we start computing the least squares spline +c according to the set of knots found at the last call of the routine. + 45 if(iopt.eq.0) go to 50 + if(n.eq.nmin) go to 50 + fp0 = fpint(n) + fpold = fpint(n-1) + nplus = nrdata(n) + if(fp0.gt.s) go to 60 + 50 n = nmin + fpold = 0.0d0 + nplus = 0 + nrdata(1) = m-2 +c main loop for the different sets of knots. m is a save upper bound +c for the number of trials. + 60 do 200 iter = 1,m + if(n.eq.nmin) ier = -2 +c find nrint, tne number of knot intervals. + nrint = n-nmin+1 +c find the position of the additional knots which are needed for +c the b-spline representation of s(x). + nk1 = n-k1 + i = n + do 70 j=1,k1 + t(j) = xb + t(i) = xe + i = i-1 + 70 continue +c compute the b-spline coefficients of the least-squares spline +c sinf(x). the observation matrix a is built up row by row and +c reduced to upper triangular form by givens transformations. +c at the same time fp=f(p=inf) is computed. + fp = 0.0d0 +c initialize the observation matrix a. + do 80 i=1,nk1 + z(i) = 0.0d0 + do 80 j=1,k1 + a(i,j) = 0.0d0 + 80 continue + l = k1 + do 130 it=1,m +c fetch the current data point x(it),y(it). + xi = x(it) + wi = w(it) + yi = y(it)*wi +c search for knot interval t(l) <= xi < t(l+1). + 85 if(xi.lt.t(l+1) .or. l.eq.nk1) go to 90 + l = l+1 + go to 85 +c evaluate the (k+1) non-zero b-splines at xi and store them in q. + 90 call fpbspl(t,n,k,xi,l,h) + do 95 i=1,k1 + q(it,i) = h(i) + h(i) = h(i)*wi + 95 continue +c rotate the new row of the observation matrix into triangle. + j = l-k1 + do 110 i=1,k1 + j = j+1 + piv = h(i) + if(piv.eq.0.0d0) go to 110 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(j,1),cos,sin) +c transformations to right hand side. + call fprota(cos,sin,yi,z(j)) + if(i.eq.k1) go to 120 + i2 = 1 + i3 = i+1 + do 100 i1 = i3,k1 + i2 = i2+1 +c transformations to left hand side. + call fprota(cos,sin,h(i1),a(j,i2)) + 100 continue + 110 continue +c add contribution of this row to the sum of squares of residual +c right hand sides. + 120 fp = fp+yi*yi + 130 continue + if(ier.eq.(-2)) fp0 = fp + fpint(n) = fp0 + fpint(n-1) = fpold + nrdata(n) = nplus +c backward substitution to obtain the b-spline coefficients. + call fpback(a,z,nk1,k1,c,nest) +c test whether the approximation sinf(x) is an acceptable solution. + if(iopt.lt.0) go to 440 + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c if f(p=inf) < s accept the choice of knots. + if(fpms.lt.0.0d0) go to 250 +c if n = nmax, sinf(x) is an interpolating spline. + if(n.eq.nmax) go to 430 +c increase the number of knots. +c if n=nest we cannot increase the number of knots because of +c the storage capacity limitation. + if(n.eq.nest) go to 420 +c determine the number of knots nplus we are going to add. + if(ier.eq.0) go to 140 + nplus = 1 + ier = 0 + go to 150 + 140 npl1 = nplus*2 + rn = nplus + if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) + nplus = min0(nplus*2,max0(npl1,nplus/2,1)) + 150 fpold = fp +c compute the sum((w(i)*(y(i)-s(x(i))))**2) for each knot interval +c t(j+k) <= x(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. + fpart = 0.0d0 + i = 1 + l = k2 + new = 0 + do 180 it=1,m + if(x(it).lt.t(l) .or. l.gt.nk1) go to 160 + new = 1 + l = l+1 + 160 term = 0.0d0 + l0 = l-k2 + do 170 j=1,k1 + l0 = l0+1 + term = term+c(l0)*q(it,j) + 170 continue + term = (w(it)*(term-y(it)))**2 + fpart = fpart+term + if(new.eq.0) go to 180 + store = term*half + fpint(i) = fpart-store + i = i+1 + fpart = store + new = 0 + 180 continue + fpint(nrint) = fpart + do 190 l=1,nplus +c add a new knot. + call fpknot(x,m,t,n,fpint,nrdata,nrint,nest,1) +c if n=nmax we locate the knots as for interpolation. + if(n.eq.nmax) go to 10 +c test whether we cannot further increase the number of knots. + if(n.eq.nest) go to 200 + 190 continue +c restart the computations with the new set of knots. + 200 continue +c test whether the least-squares kth degree polynomial is a solution +c of our approximation problem. + 250 if(ier.eq.(-2)) go to 440 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline sp(x). c +c *************************************************** c +c we have determined the number of knots and their position. c +c we now compute the b-spline coefficients of the smoothing spline c +c sp(x). the observation matrix a is extended by the rows of matrix c +c b expressing that the kth derivative discontinuities of sp(x) at c +c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c +c ponding weights of these additional rows are set to 1/p. c +c iteratively we then have to determine the value of p such that c +c f(p)=sum((w(i)*(y(i)-sp(x(i))))**2) be = s. we already know that c +c the least-squares kth degree polynomial corresponds to p=0, and c +c that the least-squares spline corresponds to p=infinity. the c +c iteration process which is proposed here, makes use of rational c +c interpolation. since f(p) is a convex and strictly decreasing c +c function of p, it can be approximated by a rational function c +c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c +c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c +c to calculate the new value of p such that r(p)=s. convergence is c +c guaranteed by taking f1>0 and f3<0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c evaluate the discontinuity jump of the kth derivative of the +c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. + call fpdisc(t,n,k2,b,nest) +c initial value for p. + p1 = 0.0d0 + f1 = fp0-s + p3 = -one + f3 = fpms + p = 0. + do 255 i=1,nk1 + p = p+a(i,1) + 255 continue + rn = nk1 + p = rn/p + ich1 = 0 + ich3 = 0 + n8 = n-nmin +c iteration process to find the root of f(p) = s. + do 360 iter=1,maxit +c the rows of matrix b with weight 1/p are rotated into the +c triangularised observation matrix a which is stored in g. + pinv = one/p + do 260 i=1,nk1 + c(i) = z(i) + g(i,k2) = 0.0d0 + do 260 j=1,k1 + g(i,j) = a(i,j) + 260 continue + do 300 it=1,n8 +c the row of matrix b is rotated into triangle by givens transformation + do 270 i=1,k2 + h(i) = b(it,i)*pinv + 270 continue + yi = 0.0d0 + do 290 j=it,nk1 + piv = h(1) +c calculate the parameters of the givens transformation. + call fpgivs(piv,g(j,1),cos,sin) +c transformations to right hand side. + call fprota(cos,sin,yi,c(j)) + if(j.eq.nk1) go to 300 + i2 = k1 + if(j.gt.n8) i2 = nk1-j + do 280 i=1,i2 +c transformations to left hand side. + i1 = i+1 + call fprota(cos,sin,h(i1),g(j,i1)) + h(i) = h(i1) + 280 continue + h(i2+1) = 0.0d0 + 290 continue + 300 continue +c backward substitution to obtain the b-spline coefficients. + call fpback(g,c,nk1,k2,c,nest) +c computation of f(p). + fp = 0.0d0 + l = k2 + do 330 it=1,m + if(x(it).lt.t(l) .or. l.gt.nk1) go to 310 + l = l+1 + 310 l0 = l-k2 + term = 0.0d0 + do 320 j=1,k1 + l0 = l0+1 + term = term+c(l0)*q(it,j) + 320 continue + fp = fp+(w(it)*(term-y(it)))**2 + 330 continue +c test whether the approximation sp(x) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c test whether the maximal number of iterations is reached. + if(iter.eq.maxit) go to 400 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 340 + if((f2-f3).gt.acc) go to 335 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p=p1*con9 + p2*con1 + go to 360 + 335 if(f2.lt.0.0d0) ich3=1 + 340 if(ich1.ne.0) go to 350 + if((f1-f2).gt.acc) go to 345 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 360 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 360 + 345 if(f2.gt.0.0d0) ich1=1 +c test whether the iteration process proceeds as theoretically +c expected. + 350 if(f2.ge.f1 .or. f2.le.f3) go to 410 +c find the new value for p. + p = fprati(p1,f1,p2,f2,p3,f3) + 360 continue +c error codes and messages. + 400 ier = 3 + go to 440 + 410 ier = 2 + go to 440 + 420 ier = 1 + go to 440 + 430 ier = -1 + 440 return + end diff --git a/fitpack/fpcuro.f b/fitpack/fpcuro.f new file mode 100644 index 0000000..856debf --- /dev/null +++ b/fitpack/fpcuro.f @@ -0,0 +1,95 @@ + recursive subroutine fpcuro(a,b,c,d,x,n) + implicit none +c subroutine fpcuro finds the real zeros of a cubic polynomial +c p(x) = a*x**3+b*x**2+c*x+d. +c +c calling sequence: +c call fpcuro(a,b,c,d,x,n) +c +c input parameters: +c a,b,c,d: real values, containing the coefficients of p(x). +c +c output parameters: +c x : real array,length 3, which contains the real zeros of p(x) +c n : integer, giving the number of real zeros of p(x). +c .. +c ..scalar arguments.. + real*8 a,b,c,d + integer n +c ..array argument.. + real*8 x(3) +c ..local scalars.. + integer i + real*8 a1,b1,c1,df,disc,d1,e3,f,four,half,ovfl,pi3,p3,q,r, + * step,tent,three,two,u,u1,u2,y +c ..function references.. + real*8 abs,max,datan,atan2,cos,sign,sqrt +c set constants + two = 0.2d+01 + three = 0.3d+01 + four = 0.4d+01 + ovfl =0.1d+05 + half = 0.5d+0 + tent = 0.1d+0 + e3 = tent/0.3d0 + pi3 = datan(0.1d+01)/0.75d0 + a1 = abs(a) + b1 = abs(b) + c1 = abs(c) + d1 = abs(d) +c test whether p(x) is a third degree polynomial. + if(max(b1,c1,d1).lt.a1*ovfl) go to 300 +c test whether p(x) is a second degree polynomial. + if(max(c1,d1).lt.b1*ovfl) go to 200 +c test whether p(x) is a first degree polynomial. + if(d1.lt.c1*ovfl) go to 100 +c p(x) is a constant function. + n = 0 + go to 800 +c p(x) is a first degree polynomial. + 100 n = 1 + x(1) = -d/c + go to 500 +c p(x) is a second degree polynomial. + 200 disc = c*c-four*b*d + n = 0 + if(disc.lt.0.) go to 800 + n = 2 + u = sqrt(disc) + b1 = b+b + x(1) = (-c+u)/b1 + x(2) = (-c-u)/b1 + go to 500 +c p(x) is a third degree polynomial. + 300 b1 = b/a*e3 + c1 = c/a + d1 = d/a + q = c1*e3-b1*b1 + r = b1*b1*b1+(d1-b1*c1)*half + disc = q*q*q+r*r + if(disc.gt.0.) go to 400 + u = sqrt(abs(q)) + if(r.lt.0.) u = -u + p3 = atan2(sqrt(-disc),abs(r))*e3 + u2 = u+u + n = 3 + x(1) = -u2*cos(p3)-b1 + x(2) = u2*cos(pi3-p3)-b1 + x(3) = u2*cos(pi3+p3)-b1 + go to 500 + 400 u = sqrt(disc) + u1 = -r+u + u2 = -r-u + n = 1 + x(1) = sign(abs(u1)**e3,u1)+sign(abs(u2)**e3,u2)-b1 +c apply a newton iteration to improve the accuracy of the roots. + 500 do 700 i=1,n + y = x(i) + f = ((a*y+b)*y+c)*y+d + df = (three*a*y+two*b)*y+c + step = 0. + if(abs(f).lt.abs(df)*tent) step = f/df + x(i) = y-step + 700 continue + 800 return + end diff --git a/fitpack/fpcyt1.f b/fitpack/fpcyt1.f new file mode 100644 index 0000000..3bc5eeb --- /dev/null +++ b/fitpack/fpcyt1.f @@ -0,0 +1,54 @@ + recursive subroutine fpcyt1(a,n,nn) + implicit none +c (l u)-decomposition of a cyclic tridiagonal matrix with the non-zero +c elements stored as follows +c +c | a(1,2) a(1,3) a(1,1) | +c | a(2,1) a(2,2) a(2,3) | +c | a(3,1) a(3,2) a(3,3) | +c | ............... | +c | a(n-1,1) a(n-1,2) a(n-1,3) | +c | a(n,3) a(n,1) a(n,2) | +c +c .. +c ..scalar arguments.. + integer n,nn +c ..array arguments.. + real*8 a(nn,6) +c ..local scalars.. + real*8 aa,beta,gamma,sum,teta,v,one + integer i,n1,n2 +c .. +c set constant + one = 1 + n2 = n-2 + beta = one/a(1,2) + gamma = a(n,3) + teta = a(1,1)*beta + a(1,4) = beta + a(1,5) = gamma + a(1,6) = teta + sum = gamma*teta + do 10 i=2,n2 + v = a(i-1,3)*beta + aa = a(i,1) + beta = one/(a(i,2)-aa*v) + gamma = -gamma*v + teta = -teta*aa*beta + a(i,4) = beta + a(i,5) = gamma + a(i,6) = teta + sum = sum+gamma*teta + 10 continue + n1 = n-1 + v = a(n2,3)*beta + aa = a(n1,1) + beta = one/(a(n1,2)-aa*v) + gamma = a(n,1)-gamma*v + teta = (a(n1,3)-teta*aa)*beta + a(n1,4) = beta + a(n1,5) = gamma + a(n1,6) = teta + a(n,4) = one/(a(n,2)-(sum+gamma*teta)) + return + end diff --git a/fitpack/fpcyt2.f b/fitpack/fpcyt2.f new file mode 100644 index 0000000..6e846eb --- /dev/null +++ b/fitpack/fpcyt2.f @@ -0,0 +1,33 @@ + recursive subroutine fpcyt2(a,n,b,c,nn) + implicit none +c subroutine fpcyt2 solves a linear n x n system +c a * c = b +c where matrix a is a cyclic tridiagonal matrix, decomposed +c using subroutine fpsyt1. +c .. +c ..scalar arguments.. + integer n,nn +c ..array arguments.. + real*8 a(nn,6),b(n),c(n) +c ..local scalars.. + real*8 cc,sum + integer i,j,j1,n1 +c .. + c(1) = b(1)*a(1,4) + sum = c(1)*a(1,5) + n1 = n-1 + do 10 i=2,n1 + c(i) = (b(i)-a(i,1)*c(i-1))*a(i,4) + sum = sum+c(i)*a(i,5) + 10 continue + cc = (b(n)-sum)*a(n,4) + c(n) = cc + c(n1) = c(n1)-cc*a(n1,6) + j = n1 + do 20 i=3,n + j1 = j-1 + c(j1) = c(j1)-c(j)*a(j1,3)*a(j1,4)-cc*a(j1,6) + j = j1 + 20 continue + return + end diff --git a/fitpack/fpdeno.f b/fitpack/fpdeno.f new file mode 100644 index 0000000..c3357a0 --- /dev/null +++ b/fitpack/fpdeno.f @@ -0,0 +1,56 @@ + recursive subroutine fpdeno(maxtr,up,left,right,nbind,merk) + implicit none +c subroutine fpdeno frees the nodes of all branches of a triply linked +c tree with length < nbind by putting to zero their up field. +c on exit the parameter merk points to the terminal node of the +c most left branch of length nbind or takes the value 1 if there +c is no such branch. +c .. +c ..scalar arguments.. + integer maxtr,nbind,merk +c ..array arguments.. + integer up(maxtr),left(maxtr),right(maxtr) +c ..local scalars .. + integer i,j,k,l,niveau,point +c .. + i = 1 + niveau = 0 + 10 point = i + i = left(point) + if(i.eq.0) go to 20 + niveau = niveau+1 + go to 10 + 20 if(niveau.eq.nbind) go to 70 + 30 i = right(point) + j = up(point) + up(point) = 0 + k = left(j) + if(point.ne.k) go to 50 + if(i.ne.0) go to 40 + niveau = niveau-1 + if(niveau.eq.0) go to 80 + point = j + go to 30 + 40 left(j) = i + go to 10 + 50 l = right(k) + if(point.eq.l) go to 60 + k = l + go to 50 + 60 right(k) = i + point = k + 70 i = right(point) + if(i.ne.0) go to 10 + i = up(point) + niveau = niveau-1 + if(niveau.eq.0) go to 80 + point = i + go to 70 + 80 k = 1 + l = left(k) + if(up(l).eq.0) return + 90 merk = k + k = left(k) + if(k.ne.0) go to 90 + return + end diff --git a/fitpack/fpdisc.f b/fitpack/fpdisc.f new file mode 100644 index 0000000..0b504bf --- /dev/null +++ b/fitpack/fpdisc.f @@ -0,0 +1,44 @@ + recursive subroutine fpdisc(t,n,k2,b,nest) + implicit none +c subroutine fpdisc calculates the discontinuity jumps of the kth +c derivative of the b-splines of degree k at the knots t(k+2)..t(n-k-1) +c ..scalar arguments.. + integer n,k2,nest +c ..array arguments.. + real*8 t(n),b(nest,k2) +c ..local scalars.. + real*8 an,fac,prod + integer i,ik,j,jk,k,k1,l,lj,lk,lmk,lp,nk1,nrint +c ..local array.. + real*8 h(12) +c .. + k1 = k2-1 + k = k1-1 + nk1 = n-k1 + nrint = nk1-k + an = nrint + fac = an/(t(nk1+1)-t(k1)) + do 40 l=k2,nk1 + lmk = l-k1 + do 10 j=1,k1 + ik = j+k1 + lj = l+j + lk = lj-k2 + h(j) = t(l)-t(lk) + h(ik) = t(l)-t(lj) + 10 continue + lp = lmk + do 30 j=1,k2 + jk = j + prod = h(j) + do 20 i=1,k + jk = jk+1 + prod = prod*h(jk)*fac + 20 continue + lk = lp+k1 + b(lmk,j) = (t(lk)-t(lp))/prod + lp = lp+1 + 30 continue + 40 continue + return + end diff --git a/fitpack/fpfrno.f b/fitpack/fpfrno.f new file mode 100644 index 0000000..30fd9c9 --- /dev/null +++ b/fitpack/fpfrno.f @@ -0,0 +1,70 @@ + recursive subroutine fpfrno(maxtr,up,left,right,info,point, + * merk,n1,count,ier) + implicit none +c subroutine fpfrno collects the free nodes (up field zero) of the +c triply linked tree the information of which is kept in the arrays +c up,left,right and info. the maximal length of the branches of the +c tree is given by n1. if no free nodes are found, the error flag +c ier is set to 1. +c .. +c ..scalar arguments.. + integer maxtr,point,merk,n1,count,ier +c ..array arguments.. + integer up(maxtr),left(maxtr),right(maxtr),info(maxtr) +c ..local scalars + integer i,j,k,l,n,niveau +c .. + ier = 1 + if(n1.eq.2) go to 140 + niveau = 1 + count = 2 + 10 j = 0 + i = 1 + 20 if(j.eq.niveau) go to 30 + k = 0 + l = left(i) + if(l.eq.0) go to 110 + i = l + j = j+1 + go to 20 + 30 if (i.lt.count) go to 110 + if (i.eq.count) go to 100 + go to 40 + 40 if(up(count).eq.0) go to 50 + count = count+1 + go to 30 + 50 up(count) = up(i) + left(count) = left(i) + right(count) = right(i) + info(count) = info(i) + if(merk.eq.i) merk = count + if(point.eq.i) point = count + if(k.eq.0) go to 60 + right(k) = count + go to 70 + 60 n = up(i) + left(n) = count + 70 l = left(i) + 80 if(l.eq.0) go to 90 + up(l) = count + l = right(l) + go to 80 + 90 up(i) = 0 + i = count + 100 count = count+1 + 110 l = right(i) + k = i + if(l.eq.0) go to 120 + i = l + go to 20 + 120 l = up(i) + j = j-1 + if(j.eq.0) go to 130 + i = l + go to 110 + 130 niveau = niveau+1 + if(niveau.le.n1) go to 10 + if(count.gt.maxtr) go to 140 + ier = 0 + 140 return + end diff --git a/fitpack/fpgivs.f b/fitpack/fpgivs.f new file mode 100644 index 0000000..fa6f7e7 --- /dev/null +++ b/fitpack/fpgivs.f @@ -0,0 +1,21 @@ + recursive subroutine fpgivs(piv,ww,cos,sin) + implicit none +c subroutine fpgivs calculates the parameters of a givens +c transformation . +c .. +c ..scalar arguments.. + real*8 piv,ww,cos,sin +c ..local scalars.. + real*8 dd,one,store +c ..function references.. + real*8 abs,sqrt +c .. + one = 0.1e+01 + store = abs(piv) + if(store.ge.ww) dd = store*sqrt(one+(ww/piv)**2) + if(store.lt.ww) dd = ww*sqrt(one+(piv/ww)**2) + cos = ww/dd + sin = piv/dd + ww = dd + return + end diff --git a/fitpack/fpgrdi.f b/fitpack/fpgrdi.f new file mode 100644 index 0000000..a9e4089 --- /dev/null +++ b/fitpack/fpgrdi.f @@ -0,0 +1,601 @@ + recursive subroutine fpgrdi(ifsu,ifsv,ifbu,ifbv,iback,u,mu,v, + * mv,z,mz,dz,iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm, + * mvnu,spu,spv,right,q,au,av1,av2,bu,bv,aa,bb,cc,cosi,nru,nrv) + implicit none +c .. +c ..scalar arguments.. + real*8 p,sq,fp + integer ifsu,ifsv,ifbu,ifbv,iback,mu,mv,mz,iop0,iop1,nu,nv,nc, + * mm,mvnu +c ..array arguments.. + real*8 u(mu),v(mv),z(mz),dz(3),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv) + *, + * spu(mu,4),spv(mv,4),right(mm),q(mvnu),au(nu,5),av1(nv,6), + * av2(nv,4),aa(2,mv),bb(2,nv),cc(nv),cosi(2,nv),bu(nu,5),bv(nv,5) + integer nru(mu),nrv(mv) +c ..local scalars.. + real*8 arg,co,dz1,dz2,dz3,fac,fac0,pinv,piv,si,term,one,three,half + * + integer i,ic,ii,ij,ik,iq,irot,it,iz,i0,i1,i2,i3,j,jj,jk,jper, + * j0,j1,k,k1,k2,l,l0,l1,l2,mvv,ncof,nrold,nroldu,nroldv,number, + * numu,numu1,numv,numv1,nuu,nu4,nu7,nu8,nu9,nv11,nv4,nv7,nv8,n1 +c ..local arrays.. + real*8 h(5),h1(5),h2(4) +c ..function references.. + integer min0 + real*8 cos,sin +c ..subroutine references.. +c fpback,fpbspl,fpgivs,fpcyt1,fpcyt2,fpdisc,fpbacp,fprota +c .. +c let +c | (spu) | | (spv) | +c (au) = | ---------- | (av) = | ---------- | +c | (1/p) (bu) | | (1/p) (bv) | +c +c | z ' 0 | +c q = | ------ | +c | 0 ' 0 | +c +c with c : the (nu-4) x (nv-4) matrix which contains the b-spline +c coefficients. +c z : the mu x mv matrix which contains the function values. +c spu,spv: the mu x (nu-4), resp. mv x (nv-4) observation matrices +c according to the least-squares problems in the u-,resp. +c v-direction. +c bu,bv : the (nu-7) x (nu-4),resp. (nv-7) x (nv-4) matrices +c containing the discontinuity jumps of the derivatives +c of the b-splines in the u-,resp.v-variable at the knots +c the b-spline coefficients of the smoothing spline are then calculated +c as the least-squares solution of the following over-determined linear +c system of equations +c +c (1) (av) c (au)' = q +c +c subject to the constraints +c +c (2) c(i,nv-3+j) = c(i,j), j=1,2,3 ; i=1,2,...,nu-4 +c +c (3) if iop0 = 0 c(1,j) = dz(1) +c iop0 = 1 c(1,j) = dz(1) +c c(2,j) = dz(1)+(dz(2)*cosi(1,j)+dz(3)*cosi(2,j))* +c tu(5)/3. = cc(j) , j=1,2,...nv-4 +c +c (4) if iop1 = 1 c(nu-4,j) = 0, j=1,2,...,nv-4. +c +c set constants + one = 1 + three = 3 + half = 0.5 +c initialization + nu4 = nu-4 + nu7 = nu-7 + nu8 = nu-8 + nu9 = nu-9 + nv4 = nv-4 + nv7 = nv-7 + nv8 = nv-8 + nv11 = nv-11 + nuu = nu4-iop0-iop1-1 + if(p.gt.0.) pinv = one/p +c it depends on the value of the flags ifsu,ifsv,ifbu,ifbv and iop0 and +c on the value of p whether the matrices (spu), (spv), (bu), (bv) and +c (cosi) still must be determined. + if(ifsu.ne.0) go to 30 +c calculate the non-zero elements of the matrix (spu) which is the ob- +c servation matrix according to the least-squares spline approximation +c problem in the u-direction. + l = 4 + l1 = 5 + number = 0 + do 25 it=1,mu + arg = u(it) + 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 15 + l = l1 + l1 = l+1 + number = number+1 + go to 10 + 15 call fpbspl(tu,nu,3,arg,l,h) + do 20 i=1,4 + spu(it,i) = h(i) + 20 continue + nru(it) = number + 25 continue + ifsu = 1 +c calculate the non-zero elements of the matrix (spv) which is the ob- +c servation matrix according to the least-squares spline approximation +c problem in the v-direction. + 30 if(ifsv.ne.0) go to 85 + l = 4 + l1 = 5 + number = 0 + do 50 it=1,mv + arg = v(it) + 35 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 40 + l = l1 + l1 = l+1 + number = number+1 + go to 35 + 40 call fpbspl(tv,nv,3,arg,l,h) + do 45 i=1,4 + spv(it,i) = h(i) + 45 continue + nrv(it) = number + 50 continue + ifsv = 1 + if(iop0.eq.0) go to 85 +c calculate the coefficients of the interpolating splines for cos(v) +c and sin(v). + do 55 i=1,nv4 + cosi(1,i) = 0. + cosi(2,i) = 0. + 55 continue + if(nv7.lt.4) go to 85 + do 65 i=1,nv7 + l = i+3 + arg = tv(l) + call fpbspl(tv,nv,3,arg,l,h) + do 60 j=1,3 + av1(i,j) = h(j) + 60 continue + cosi(1,i) = cos(arg) + cosi(2,i) = sin(arg) + 65 continue + call fpcyt1(av1,nv7,nv) + do 80 j=1,2 + do 70 i=1,nv7 + right(i) = cosi(j,i) + 70 continue + call fpcyt2(av1,nv7,right,right,nv) + do 75 i=1,nv7 + cosi(j,i+1) = right(i) + 75 continue + cosi(j,1) = cosi(j,nv7+1) + cosi(j,nv7+2) = cosi(j,2) + cosi(j,nv4) = cosi(j,3) + 80 continue + 85 if(p.le.0.) go to 150 +c calculate the non-zero elements of the matrix (bu). + if(ifbu.ne.0 .or. nu8.eq.0) go to 90 + call fpdisc(tu,nu,5,bu,nu) + ifbu = 1 +c calculate the non-zero elements of the matrix (bv). + 90 if(ifbv.ne.0 .or. nv8.eq.0) go to 150 + call fpdisc(tv,nv,5,bv,nv) + ifbv = 1 +c substituting (2),(3) and (4) into (1), we obtain the overdetermined +c system +c (5) (avv) (cr) (auu)' = (qq) +c from which the nuu*nv7 remaining coefficients +c c(i,j) , i=2+iop0,3+iop0,...,nu-4-iop1 ; j=1,2,...,nv-7 , +c the elements of (cr), are then determined in the least-squares sense. +c simultaneously, we compute the resulting sum of squared residuals sq. + 150 dz1 = dz(1) + do 155 i=1,mv + aa(1,i) = dz1 + 155 continue + if(nv8.eq.0 .or. p.le.0.) go to 165 + do 160 i=1,nv8 + bb(1,i) = 0. + 160 continue + 165 mvv = mv + if(iop0.eq.0) go to 220 + fac = tu(5)/three + dz2 = dz(2)*fac + dz3 = dz(3)*fac + do 170 i=1,nv4 + cc(i) = dz1+dz2*cosi(1,i)+dz3*cosi(2,i) + 170 continue + do 190 i=1,mv + number = nrv(i) + fac = 0. + do 180 j=1,4 + number = number+1 + fac = fac+cc(number)*spv(i,j) + 180 continue + aa(2,i) = fac + 190 continue + if(nv8.eq.0 .or. p.le.0.) go to 220 + do 210 i=1,nv8 + number = i + fac = 0. + do 200 j=1,5 + fac = fac+cc(number)*bv(i,j) + number = number+1 + 200 continue + bb(2,i) = fac*pinv + 210 continue + mvv = mvv+nv8 +c we first determine the matrices (auu) and (qq). then we reduce the +c matrix (auu) to upper triangular form (ru) using givens rotations. +c we apply the same transformations to the rows of matrix qq to obtain +c the (mv+nv8) x nuu matrix g. +c we store matrix (ru) into au and g into q. + 220 l = mvv*nuu +c initialization. + sq = 0. + do 230 i=1,l + q(i) = 0. + 230 continue + do 240 i=1,nuu + do 240 j=1,5 + au(i,j) = 0. + 240 continue + l = 0 + nrold = 0 + n1 = nrold+1 + do 420 it=1,mu + number = nru(it) +c find the appropriate column of q. + 250 do 260 j=1,mvv + right(j) = 0. + 260 continue + if(nrold.eq.number) go to 280 + if(p.le.0.) go to 410 +c fetch a new row of matrix (bu). + do 270 j=1,5 + h(j) = bu(n1,j)*pinv + 270 continue + i0 = 1 + i1 = 5 + go to 310 +c fetch a new row of matrix (spu). + 280 do 290 j=1,4 + h(j) = spu(it,j) + 290 continue +c find the appropriate column of q. + do 300 j=1,mv + l = l+1 + right(j) = z(l) + 300 continue + i0 = 1 + i1 = 4 + 310 if(nu7-number .eq. iop1) i1 = i1-1 + j0 = n1 +c take into account that we eliminate the constraints (3) + 320 if(j0-1.gt.iop0) go to 360 + fac0 = h(i0) + do 330 j=1,mv + right(j) = right(j)-fac0*aa(j0,j) + 330 continue + if(mv.eq.mvv) go to 350 + j = mv + do 340 jj=1,nv8 + j = j+1 + right(j) = right(j)-fac0*bb(j0,jj) + 340 continue + 350 j0 = j0+1 + i0 = i0+1 + go to 320 + 360 irot = nrold-iop0-1 + if(irot.lt.0) irot = 0 +c rotate the new row of matrix (auu) into triangle. + do 390 i=i0,i1 + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 390 +c calculate the parameters of the givens transformation. + call fpgivs(piv,au(irot,1),co,si) +c apply that transformation to the rows of matrix (qq). + iq = (irot-1)*mvv + do 370 j=1,mvv + iq = iq+1 + call fprota(co,si,right(j),q(iq)) + 370 continue +c apply that transformation to the columns of (auu). + if(i.eq.i1) go to 390 + i2 = 1 + i3 = i+1 + do 380 j=i3,i1 + i2 = i2+1 + call fprota(co,si,h(j),au(irot,i2)) + 380 continue + 390 continue +c we update the sum of squared residuals + do 395 j=1,mvv + sq = sq+right(j)**2 + 395 continue + if(nrold.eq.number) go to 420 + 410 nrold = n1 + n1 = n1+1 + go to 250 + 420 continue +c we determine the matrix (avv) and then we reduce her to +c upper triangular form (rv) using givens rotations. +c we apply the same transformations to the columns of matrix +c g to obtain the (nv-7) x (nu-5-iop0-iop1) matrix h. +c we store matrix (rv) into av1 and av2, h into c. +c the nv7 x nv7 upper triangular matrix (rv) has the form +c | av1 ' | +c (rv) = | ' av2 | +c | 0 ' | +c with (av2) a nv7 x 4 matrix and (av1) a nv11 x nv11 upper +c triangular matrix of bandwidth 5. + ncof = nuu*nv7 +c initialization. + do 430 i=1,ncof + c(i) = 0. + 430 continue + do 440 i=1,nv4 + av1(i,5) = 0. + do 440 j=1,4 + av1(i,j) = 0. + av2(i,j) = 0. + 440 continue + jper = 0 + nrold = 0 + do 770 it=1,mv + number = nrv(it) + 450 if(nrold.eq.number) go to 480 + if(p.le.0.) go to 760 +c fetch a new row of matrix (bv). + n1 = nrold+1 + do 460 j=1,5 + h(j) = bv(n1,j)*pinv + 460 continue +c find the appropriate row of g. + do 465 j=1,nuu + right(j) = 0. + 465 continue + if(mv.eq.mvv) go to 510 + l = mv+n1 + do 470 j=1,nuu + right(j) = q(l) + l = l+mvv + 470 continue + go to 510 +c fetch a new row of matrix (spv) + 480 h(5) = 0. + do 490 j=1,4 + h(j) = spv(it,j) + 490 continue +c find the appropriate row of g. + l = it + do 500 j=1,nuu + right(j) = q(l) + l = l+mvv + 500 continue +c test whether there are non-zero values in the new row of (avv) +c corresponding to the b-splines n(j,v),j=nv7+1,...,nv4. + 510 if(nrold.lt.nv11) go to 710 + if(jper.ne.0) go to 550 +c initialize the matrix (av2). + jk = nv11+1 + do 540 i=1,4 + ik = jk + do 520 j=1,5 + if(ik.le.0) go to 530 + av2(ik,i) = av1(ik,j) + ik = ik-1 + 520 continue + 530 jk = jk+1 + 540 continue + jper = 1 +c if one of the non-zero elements of the new row corresponds to one of +c the b-splines n(j;v),j=nv7+1,...,nv4, we take account of condition +c (2) for setting up this row of (avv). the row is stored in h1( the +c part with respect to av1) and h2 (the part with respect to av2). + 550 do 560 i=1,4 + h1(i) = 0. + h2(i) = 0. + 560 continue + h1(5) = 0. + j = nrold-nv11 + do 600 i=1,5 + j = j+1 + l0 = j + 570 l1 = l0-4 + if(l1.le.0) go to 590 + if(l1.le.nv11) go to 580 + l0 = l1-nv11 + go to 570 + 580 h1(l1) = h(i) + go to 600 + 590 h2(l0) = h2(l0) + h(i) + 600 continue +c rotate the new row of (avv) into triangle. + if(nv11.le.0) go to 670 +c rotations with the rows 1,2,...,nv11 of (avv). + do 660 j=1,nv11 + piv = h1(1) + i2 = min0(nv11-j,4) + if(piv.eq.0.) go to 640 +c calculate the parameters of the givens transformation. + call fpgivs(piv,av1(j,1),co,si) +c apply that transformation to the columns of matrix g. + ic = j + do 610 i=1,nuu + call fprota(co,si,right(i),c(ic)) + ic = ic+nv7 + 610 continue +c apply that transformation to the rows of (avv) with respect to av2. + do 620 i=1,4 + call fprota(co,si,h2(i),av2(j,i)) + 620 continue +c apply that transformation to the rows of (avv) with respect to av1. + if(i2.eq.0) go to 670 + do 630 i=1,i2 + i1 = i+1 + call fprota(co,si,h1(i1),av1(j,i1)) + 630 continue + 640 do 650 i=1,i2 + h1(i) = h1(i+1) + 650 continue + h1(i2+1) = 0. + 660 continue +c rotations with the rows nv11+1,...,nv7 of avv. + 670 do 700 j=1,4 + ij = nv11+j + if(ij.le.0) go to 700 + piv = h2(j) + if(piv.eq.0.) go to 700 +c calculate the parameters of the givens transformation. + call fpgivs(piv,av2(ij,j),co,si) +c apply that transformation to the columns of matrix g. + ic = ij + do 680 i=1,nuu + call fprota(co,si,right(i),c(ic)) + ic = ic+nv7 + 680 continue + if(j.eq.4) go to 700 +c apply that transformation to the rows of (avv) with respect to av2. + j1 = j+1 + do 690 i=j1,4 + call fprota(co,si,h2(i),av2(ij,i)) + 690 continue + 700 continue +c we update the sum of squared residuals + do 705 i=1,nuu + sq = sq+right(i)**2 + 705 continue + go to 750 +c rotation into triangle of the new row of (avv), in case the elements +c corresponding to the b-splines n(j;v),j=nv7+1,...,nv4 are all zero. + 710 irot =nrold + do 740 i=1,5 + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 740 +c calculate the parameters of the givens transformation. + call fpgivs(piv,av1(irot,1),co,si) +c apply that transformation to the columns of matrix g. + ic = irot + do 720 j=1,nuu + call fprota(co,si,right(j),c(ic)) + ic = ic+nv7 + 720 continue +c apply that transformation to the rows of (avv). + if(i.eq.5) go to 740 + i2 = 1 + i3 = i+1 + do 730 j=i3,5 + i2 = i2+1 + call fprota(co,si,h(j),av1(irot,i2)) + 730 continue + 740 continue +c we update the sum of squared residuals + do 745 i=1,nuu + sq = sq+right(i)**2 + 745 continue + 750 if(nrold.eq.number) go to 770 + 760 nrold = nrold+1 + go to 450 + 770 continue +c test whether the b-spline coefficients must be determined. + if(iback.ne.0) return +c backward substitution to obtain the b-spline coefficients as the +c solution of the linear system (rv) (cr) (ru)' = h. +c first step: solve the system (rv) (c1) = h. + k = 1 + do 780 i=1,nuu + call fpbacp(av1,av2,c(k),nv7,4,c(k),5,nv) + k = k+nv7 + 780 continue +c second step: solve the system (cr) (ru)' = (c1). + k = 0 + do 800 j=1,nv7 + k = k+1 + l = k + do 790 i=1,nuu + right(i) = c(l) + l = l+nv7 + 790 continue + call fpback(au,right,nuu,5,right,nu) + l = k + do 795 i=1,nuu + c(l) = right(i) + l = l+nv7 + 795 continue + 800 continue +c calculate from the conditions (2)-(3)-(4), the remaining b-spline +c coefficients. + ncof = nu4*nv4 + i = nv4 + j = 0 + do 805 l=1,nv4 + q(l) = dz1 + 805 continue + if(iop0.eq.0) go to 815 + do 810 l=1,nv4 + i = i+1 + q(i) = cc(l) + 810 continue + 815 if(nuu.eq.0) go to 850 + do 840 l=1,nuu + ii = i + do 820 k=1,nv7 + i = i+1 + j = j+1 + q(i) = c(j) + 820 continue + do 830 k=1,3 + ii = ii+1 + i = i+1 + q(i) = q(ii) + 830 continue + 840 continue + 850 if(iop1.eq.0) go to 870 + do 860 l=1,nv4 + i = i+1 + q(i) = 0. + 860 continue + 870 do 880 i=1,ncof + c(i) = q(i) + 880 continue +c calculate the quantities +c res(i,j) = (z(i,j) - s(u(i),v(j)))**2 , i=1,2,..,mu;j=1,2,..,mv +c fp = sumi=1,mu(sumj=1,mv(res(i,j))) +c fpu(r) = sum''i(sumj=1,mv(res(i,j))) , r=1,2,...,nu-7 +c tu(r+3) <= u(i) <= tu(r+4) +c fpv(r) = sumi=1,mu(sum''j(res(i,j))) , r=1,2,...,nv-7 +c tv(r+3) <= v(j) <= tv(r+4) + fp = 0. + do 890 i=1,nu + fpu(i) = 0. + 890 continue + do 900 i=1,nv + fpv(i) = 0. + 900 continue + iz = 0 + nroldu = 0 +c main loop for the different grid points. + do 950 i1=1,mu + numu = nru(i1) + numu1 = numu+1 + nroldv = 0 + do 940 i2=1,mv + numv = nrv(i2) + numv1 = numv+1 + iz = iz+1 +c evaluate s(u,v) at the current grid point by making the sum of the +c cross products of the non-zero b-splines at (u,v), multiplied with +c the appropriate b-spline coefficients. + term = 0. + k1 = numu*nv4+numv + do 920 l1=1,4 + k2 = k1 + fac = spu(i1,l1) + do 910 l2=1,4 + k2 = k2+1 + term = term+fac*spv(i2,l2)*c(k2) + 910 continue + k1 = k1+nv4 + 920 continue +c calculate the squared residual at the current grid point. + term = (z(iz)-term)**2 +c adjust the different parameters. + fp = fp+term + fpu(numu1) = fpu(numu1)+term + fpv(numv1) = fpv(numv1)+term + fac = term*half + if(numv.eq.nroldv) go to 930 + fpv(numv1) = fpv(numv1)-fac + fpv(numv) = fpv(numv)+fac + 930 nroldv = numv + if(numu.eq.nroldu) go to 940 + fpu(numu1) = fpu(numu1)-fac + fpu(numu) = fpu(numu)+fac + 940 continue + nroldu = numu + 950 continue + return + end diff --git a/fitpack/fpgrpa.f b/fitpack/fpgrpa.f new file mode 100644 index 0000000..3272056 --- /dev/null +++ b/fitpack/fpgrpa.f @@ -0,0 +1,314 @@ + recursive subroutine fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu, + * v,mv,z,mz,tu,nu,tv,nv,p,c,nc,fp,fpu,fpv,mm,mvnu,spu,spv, + * right,q,au,au1,av,av1,bu,bv,nru,nrv) + implicit none +c .. +c ..scalar arguments.. + real*8 p,fp + integer ifsu,ifsv,ifbu,ifbv,idim,mu,mv,mz,nu,nv,nc,mm,mvnu +c ..array arguments.. + real*8 u(mu),v(mv),z(mz*idim),tu(nu),tv(nv),c(nc*idim),fpu(nu), + * fpv(nv),spu(mu,4),spv(mv,4),right(mm*idim),q(mvnu),au(nu,5), + * au1(nu,4),av(nv,5),av1(nv,4),bu(nu,5),bv(nv,5) + integer ipar(2),nru(mu),nrv(mv) +c ..local scalars.. + real*8 arg,fac,term,one,half,value + integer i,id,ii,it,iz,i1,i2,j,jz,k,k1,k2,l,l1,l2,mvv,k0,muu, + * ncof,nroldu,nroldv,number,nmd,numu,numu1,numv,numv1,nuu,nvv, + * nu4,nu7,nu8,nv4,nv7,nv8, n33 +c ..local arrays.. + real*8 h(5) +c ..subroutine references.. +c fpback,fpbspl,fpdisc,fpbacp,fptrnp,fptrpe +c .. +c let +c | (spu) | | (spv) | +c (au) = | ---------- | (av) = | ---------- | +c | (1/p) (bu) | | (1/p) (bv) | +c +c | z ' 0 | +c q = | ------ | +c | 0 ' 0 | +c +c with c : the (nu-4) x (nv-4) matrix which contains the b-spline +c coefficients. +c z : the mu x mv matrix which contains the function values. +c spu,spv: the mu x (nu-4), resp. mv x (nv-4) observation matrices +c according to the least-squares problems in the u-,resp. +c v-direction. +c bu,bv : the (nu-7) x (nu-4),resp. (nv-7) x (nv-4) matrices +c containing the discontinuity jumps of the derivatives +c of the b-splines in the u-,resp.v-variable at the knots +c the b-spline coefficients of the smoothing spline are then calculated +c as the least-squares solution of the following over-determined linear +c system of equations +c +c (1) (av) c (au)' = q +c +c subject to the constraints +c +c (2) c(nu-3+i,j) = c(i,j), i=1,2,3 ; j=1,2,...,nv-4 +c if(ipar(1).ne.0) +c +c (3) c(i,nv-3+j) = c(i,j), j=1,2,3 ; i=1,2,...,nu-4 +c if(ipar(2).ne.0) +c +c set constants + one = 1 + half = 0.5 +c initialization + nu4 = nu-4 + nu7 = nu-7 + nu8 = nu-8 + nv4 = nv-4 + nv7 = nv-7 + nv8 = nv-8 + muu = mu + if(ipar(1).ne.0) muu = mu-1 + mvv = mv + if(ipar(2).ne.0) mvv = mv-1 +c it depends on the value of the flags ifsu,ifsv,ifbu and ibvand +c on the value of p whether the matrices (spu), (spv), (bu) and (bv) +c still must be determined. + if(ifsu.ne.0) go to 50 +c calculate the non-zero elements of the matrix (spu) which is the ob- +c servation matrix according to the least-squares spline approximation +c problem in the u-direction. + l = 4 + l1 = 5 + number = 0 + do 40 it=1,muu + arg = u(it) + 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 20 + l = l1 + l1 = l+1 + number = number+1 + go to 10 + 20 call fpbspl(tu,nu,3,arg,l,h) + do 30 i=1,4 + spu(it,i) = h(i) + 30 continue + nru(it) = number + 40 continue + ifsu = 1 +c calculate the non-zero elements of the matrix (spv) which is the ob- +c servation matrix according to the least-squares spline approximation +c problem in the v-direction. + 50 if(ifsv.ne.0) go to 100 + l = 4 + l1 = 5 + number = 0 + do 90 it=1,mvv + arg = v(it) + 60 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 70 + l = l1 + l1 = l+1 + number = number+1 + go to 60 + 70 call fpbspl(tv,nv,3,arg,l,h) + do 80 i=1,4 + spv(it,i) = h(i) + 80 continue + nrv(it) = number + 90 continue + ifsv = 1 + 100 if(p.le.0.) go to 150 +c calculate the non-zero elements of the matrix (bu). + if(ifbu.ne.0 .or. nu8.eq.0) go to 110 + call fpdisc(tu,nu,5,bu,nu) + ifbu = 1 +c calculate the non-zero elements of the matrix (bv). + 110 if(ifbv.ne.0 .or. nv8.eq.0) go to 150 + call fpdisc(tv,nv,5,bv,nv) + ifbv = 1 +c substituting (2) and (3) into (1), we obtain the overdetermined +c system +c (4) (avv) (cr) (auu)' = (qq) +c from which the nuu*nvv remaining coefficients +c c(i,j) , i=1,...,nu-4-3*ipar(1) ; j=1,...,nv-4-3*ipar(2) , +c the elements of (cr), are then determined in the least-squares sense. +c we first determine the matrices (auu) and (qq). then we reduce the +c matrix (auu) to upper triangular form (ru) using givens rotations. +c we apply the same transformations to the rows of matrix qq to obtain +c the (mv) x nuu matrix g. +c we store matrix (ru) into au (and au1 if ipar(1)=1) and g into q. + 150 if(ipar(1).ne.0) go to 160 + nuu = nu4 + call fptrnp(mu,mv,idim,nu,nru,spu,p,bu,z,au,q,right) + go to 180 + 160 nuu = nu7 + call fptrpe(mu,mv,idim,nu,nru,spu,p,bu,z,au,au1,q,right) +c we determine the matrix (avv) and then we reduce this matrix to +c upper triangular form (rv) using givens rotations. +c we apply the same transformations to the columns of matrix +c g to obtain the (nvv) x (nuu) matrix h. +c we store matrix (rv) into av (and av1 if ipar(2)=1) and h into c. + 180 if(ipar(2).ne.0) go to 190 + nvv = nv4 + call fptrnp(mv,nuu,idim,nv,nrv,spv,p,bv,q,av,c,right) + go to 200 + 190 nvv = nv7 + call fptrpe(mv,nuu,idim,nv,nrv,spv,p,bv,q,av,av1,c,right) +c backward substitution to obtain the b-spline coefficients as the +c solution of the linear system (rv) (cr) (ru)' = h. +c first step: solve the system (rv) (c1) = h. + 200 ncof = nuu*nvv + k = 1 + if(ipar(2).ne.0) go to 240 + do 220 ii=1,idim + do 220 i=1,nuu + call fpback(av,c(k),nvv,5,c(k),nv) + k = k+nvv + 220 continue + go to 300 + 240 do 260 ii=1,idim + do 260 i=1,nuu + call fpbacp(av,av1,c(k),nvv,4,c(k),5,nv) + k = k+nvv + 260 continue +c second step: solve the system (cr) (ru)' = (c1). + 300 if(ipar(1).ne.0) go to 400 + do 360 ii=1,idim + k = (ii-1)*ncof + do 360 j=1,nvv + k = k+1 + l = k + do 320 i=1,nuu + right(i) = c(l) + l = l+nvv + 320 continue + call fpback(au,right,nuu,5,right,nu) + l = k + do 340 i=1,nuu + c(l) = right(i) + l = l+nvv + 340 continue + 360 continue + go to 500 + 400 do 460 ii=1,idim + k = (ii-1)*ncof + do 460 j=1,nvv + k = k+1 + l = k + do 420 i=1,nuu + right(i) = c(l) + l = l+nvv + 420 continue + call fpbacp(au,au1,right,nuu,4,right,5,nu) + l = k + do 440 i=1,nuu + c(l) = right(i) + l = l+nvv + 440 continue + 460 continue +c calculate from the conditions (2)-(3), the remaining b-spline +c coefficients. + 500 if(ipar(2).eq.0) go to 600 + i = 0 + j = 0 + do 560 id=1,idim + do 560 l=1,nuu + ii = i + do 520 k=1,nvv + i = i+1 + j = j+1 + q(i) = c(j) + 520 continue + do 540 k=1,3 + ii = ii+1 + i = i+1 + q(i) = q(ii) + 540 continue + 560 continue + ncof = nv4*nuu + nmd = ncof*idim + do 580 i=1,nmd + c(i) = q(i) + 580 continue + 600 if(ipar(1).eq.0) go to 700 + i = 0 + j = 0 + n33 = 3*nv4 + do 660 id=1,idim + ii = i + do 620 k=1,ncof + i = i+1 + j = j+1 + q(i) = c(j) + 620 continue + do 640 k=1,n33 + ii = ii+1 + i = i+1 + q(i) = q(ii) + 640 continue + 660 continue + ncof = nv4*nu4 + nmd = ncof*idim + do 680 i=1,nmd + c(i) = q(i) + 680 continue +c calculate the quantities +c res(i,j) = (z(i,j) - s(u(i),v(j)))**2 , i=1,2,..,mu;j=1,2,..,mv +c fp = sumi=1,mu(sumj=1,mv(res(i,j))) +c fpu(r) = sum''i(sumj=1,mv(res(i,j))) , r=1,2,...,nu-7 +c tu(r+3) <= u(i) <= tu(r+4) +c fpv(r) = sumi=1,mu(sum''j(res(i,j))) , r=1,2,...,nv-7 +c tv(r+3) <= v(j) <= tv(r+4) + 700 fp = 0. + do 720 i=1,nu + fpu(i) = 0. + 720 continue + do 740 i=1,nv + fpv(i) = 0. + 740 continue + nroldu = 0 +c main loop for the different grid points. + do 860 i1=1,muu + numu = nru(i1) + numu1 = numu+1 + nroldv = 0 + iz = (i1-1)*mv + do 840 i2=1,mvv + numv = nrv(i2) + numv1 = numv+1 + iz = iz+1 +c evaluate s(u,v) at the current grid point by making the sum of the +c cross products of the non-zero b-splines at (u,v), multiplied with +c the appropriate b-spline coefficients. + term = 0. + k0 = numu*nv4+numv + jz = iz + do 800 id=1,idim + k1 = k0 + value = 0. + do 780 l1=1,4 + k2 = k1 + fac = spu(i1,l1) + do 760 l2=1,4 + k2 = k2+1 + value = value+fac*spv(i2,l2)*c(k2) + 760 continue + k1 = k1+nv4 + 780 continue +c calculate the squared residual at the current grid point. + term = term+(z(jz)-value)**2 + jz = jz+mz + k0 = k0+ncof + 800 continue +c adjust the different parameters. + fp = fp+term + fpu(numu1) = fpu(numu1)+term + fpv(numv1) = fpv(numv1)+term + fac = term*half + if(numv.eq.nroldv) go to 820 + fpv(numv1) = fpv(numv1)-fac + fpv(numv) = fpv(numv)+fac + 820 nroldv = numv + if(numu.eq.nroldu) go to 840 + fpu(numu1) = fpu(numu1)-fac + fpu(numu) = fpu(numu)+fac + 840 continue + nroldu = numu + 860 continue + return + end diff --git a/fitpack/fpgrre.f b/fitpack/fpgrre.f new file mode 100644 index 0000000..0138df9 --- /dev/null +++ b/fitpack/fpgrre.f @@ -0,0 +1,329 @@ + recursive subroutine fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz, + * kx,ky,tx,nx,ty,ny,p,c,nc,fp,fpx,fpy,mm,mynx,kx1,kx2,ky1,ky2, + * spx,spy,right,q,ax,ay,bx,by,nrx,nry) + implicit none +c .. +c ..scalar arguments.. + real*8 p,fp + integer ifsx,ifsy,ifbx,ifby,mx,my,mz,kx,ky,nx,ny,nc,mm,mynx, + * kx1,kx2,ky1,ky2 +c ..array arguments.. + real*8 x(mx),y(my),z(mz),tx(nx),ty(ny),c(nc),spx(mx,kx1),spy(my,ky + *1) + * ,right(mm),q(mynx),ax(nx,kx2),bx(nx,kx2),ay(ny,ky2),by(ny,ky2), + * fpx(nx),fpy(ny) + integer nrx(mx),nry(my) +c ..local scalars.. + real*8 arg,cos,fac,pinv,piv,sin,term,one,half + integer i,ibandx,ibandy,ic,iq,irot,it,iz,i1,i2,i3,j,k,k1,k2,l, + * l1,l2,ncof,nk1x,nk1y,nrold,nroldx,nroldy,number,numx,numx1, + * numy,numy1,n1 +c ..local arrays.. + real*8 h(7) +c ..subroutine references.. +c fpback,fpbspl,fpgivs,fpdisc,fprota +c .. +c the b-spline coefficients of the smoothing spline are calculated as +c the least-squares solution of the over-determined linear system of +c equations (ay) c (ax)' = q where +c +c | (spx) | | (spy) | +c (ax) = | ---------- | (ay) = | ---------- | +c | (1/p) (bx) | | (1/p) (by) | +c +c | z ' 0 | +c q = | ------ | +c | 0 ' 0 | +c +c with c : the (ny-ky-1) x (nx-kx-1) matrix which contains the +c b-spline coefficients. +c z : the my x mx matrix which contains the function values. +c spx,spy: the mx x (nx-kx-1) and my x (ny-ky-1) observation +c matrices according to the least-squares problems in +c the x- and y-direction. +c bx,by : the (nx-2*kx-1) x (nx-kx-1) and (ny-2*ky-1) x (ny-ky-1) +c matrices which contain the discontinuity jumps of the +c derivatives of the b-splines in the x- and y-direction. + one = 1 + half = 0.5 + nk1x = nx-kx1 + nk1y = ny-ky1 + if(p.gt.0.) pinv = one/p +c it depends on the value of the flags ifsx,ifsy,ifbx and ifby and on +c the value of p whether the matrices (spx),(spy),(bx) and (by) still +c must be determined. + if(ifsx.ne.0) go to 50 +c calculate the non-zero elements of the matrix (spx) which is the +c observation matrix according to the least-squares spline approximat- +c ion problem in the x-direction. + l = kx1 + l1 = kx2 + number = 0 + do 40 it=1,mx + arg = x(it) + 10 if(arg.lt.tx(l1) .or. l.eq.nk1x) go to 20 + l = l1 + l1 = l+1 + number = number+1 + go to 10 + 20 call fpbspl(tx,nx,kx,arg,l,h) + do 30 i=1,kx1 + spx(it,i) = h(i) + 30 continue + nrx(it) = number + 40 continue + ifsx = 1 + 50 if(ifsy.ne.0) go to 100 +c calculate the non-zero elements of the matrix (spy) which is the +c observation matrix according to the least-squares spline approximat- +c ion problem in the y-direction. + l = ky1 + l1 = ky2 + number = 0 + do 90 it=1,my + arg = y(it) + 60 if(arg.lt.ty(l1) .or. l.eq.nk1y) go to 70 + l = l1 + l1 = l+1 + number = number+1 + go to 60 + 70 call fpbspl(ty,ny,ky,arg,l,h) + do 80 i=1,ky1 + spy(it,i) = h(i) + 80 continue + nry(it) = number + 90 continue + ifsy = 1 + 100 if(p.le.0.) go to 120 +c calculate the non-zero elements of the matrix (bx). + if(ifbx.ne.0 .or. nx.eq.2*kx1) go to 110 + call fpdisc(tx,nx,kx2,bx,nx) + ifbx = 1 +c calculate the non-zero elements of the matrix (by). + 110 if(ifby.ne.0 .or. ny.eq.2*ky1) go to 120 + call fpdisc(ty,ny,ky2,by,ny) + ifby = 1 +c reduce the matrix (ax) to upper triangular form (rx) using givens +c rotations. apply the same transformations to the rows of matrix q +c to obtain the my x (nx-kx-1) matrix g. +c store matrix (rx) into (ax) and g into q. + 120 l = my*nk1x +c initialization. + do 130 i=1,l + q(i) = 0. + 130 continue + do 140 i=1,nk1x + do 140 j=1,kx2 + ax(i,j) = 0. + 140 continue + l = 0 + nrold = 0 +c ibandx denotes the bandwidth of the matrices (ax) and (rx). + ibandx = kx1 + do 270 it=1,mx + number = nrx(it) + 150 if(nrold.eq.number) go to 180 + if(p.le.0.) go to 260 + ibandx = kx2 +c fetch a new row of matrix (bx). + n1 = nrold+1 + do 160 j=1,kx2 + h(j) = bx(n1,j)*pinv + 160 continue +c find the appropriate column of q. + do 170 j=1,my + right(j) = 0. + 170 continue + irot = nrold + go to 210 +c fetch a new row of matrix (spx). + 180 h(ibandx) = 0. + do 190 j=1,kx1 + h(j) = spx(it,j) + 190 continue +c find the appropriate column of q. + do 200 j=1,my + l = l+1 + right(j) = z(l) + 200 continue + irot = number +c rotate the new row of matrix (ax) into triangle. + 210 do 240 i=1,ibandx + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 240 +c calculate the parameters of the givens transformation. + call fpgivs(piv,ax(irot,1),cos,sin) +c apply that transformation to the rows of matrix q. + iq = (irot-1)*my + do 220 j=1,my + iq = iq+1 + call fprota(cos,sin,right(j),q(iq)) + 220 continue +c apply that transformation to the columns of (ax). + if(i.eq.ibandx) go to 250 + i2 = 1 + i3 = i+1 + do 230 j=i3,ibandx + i2 = i2+1 + call fprota(cos,sin,h(j),ax(irot,i2)) + 230 continue + 240 continue + 250 if(nrold.eq.number) go to 270 + 260 nrold = nrold+1 + go to 150 + 270 continue +c reduce the matrix (ay) to upper triangular form (ry) using givens +c rotations. apply the same transformations to the columns of matrix g +c to obtain the (ny-ky-1) x (nx-kx-1) matrix h. +c store matrix (ry) into (ay) and h into c. + ncof = nk1x*nk1y +c initialization. + do 280 i=1,ncof + c(i) = 0. + 280 continue + do 290 i=1,nk1y + do 290 j=1,ky2 + ay(i,j) = 0. + 290 continue + nrold = 0 +c ibandy denotes the bandwidth of the matrices (ay) and (ry). + ibandy = ky1 + do 420 it=1,my + number = nry(it) + 300 if(nrold.eq.number) go to 330 + if(p.le.0.) go to 410 + ibandy = ky2 +c fetch a new row of matrix (by). + n1 = nrold+1 + do 310 j=1,ky2 + h(j) = by(n1,j)*pinv + 310 continue +c find the appropriate row of g. + do 320 j=1,nk1x + right(j) = 0. + 320 continue + irot = nrold + go to 360 +c fetch a new row of matrix (spy) + 330 h(ibandy) = 0. + do 340 j=1,ky1 + h(j) = spy(it,j) + 340 continue +c find the appropriate row of g. + l = it + do 350 j=1,nk1x + right(j) = q(l) + l = l+my + 350 continue + irot = number +c rotate the new row of matrix (ay) into triangle. + 360 do 390 i=1,ibandy + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 390 +c calculate the parameters of the givens transformation. + call fpgivs(piv,ay(irot,1),cos,sin) +c apply that transformation to the columns of matrix g. + ic = irot + do 370 j=1,nk1x + call fprota(cos,sin,right(j),c(ic)) + ic = ic+nk1y + 370 continue +c apply that transformation to the columns of matrix (ay). + if(i.eq.ibandy) go to 400 + i2 = 1 + i3 = i+1 + do 380 j=i3,ibandy + i2 = i2+1 + call fprota(cos,sin,h(j),ay(irot,i2)) + 380 continue + 390 continue + 400 if(nrold.eq.number) go to 420 + 410 nrold = nrold+1 + go to 300 + 420 continue +c backward substitution to obtain the b-spline coefficients as the +c solution of the linear system (ry) c (rx)' = h. +c first step: solve the system (ry) (c1) = h. + k = 1 + do 450 i=1,nk1x + call fpback(ay,c(k),nk1y,ibandy,c(k),ny) + k = k+nk1y + 450 continue +c second step: solve the system c (rx)' = (c1). + k = 0 + do 480 j=1,nk1y + k = k+1 + l = k + do 460 i=1,nk1x + right(i) = c(l) + l = l+nk1y + 460 continue + call fpback(ax,right,nk1x,ibandx,right,nx) + l = k + do 470 i=1,nk1x + c(l) = right(i) + l = l+nk1y + 470 continue + 480 continue +c calculate the quantities +c res(i,j) = (z(i,j) - s(x(i),y(j)))**2 , i=1,2,..,mx;j=1,2,..,my +c fp = sumi=1,mx(sumj=1,my(res(i,j))) +c fpx(r) = sum''i(sumj=1,my(res(i,j))) , r=1,2,...,nx-2*kx-1 +c tx(r+kx) <= x(i) <= tx(r+kx+1) +c fpy(r) = sumi=1,mx(sum''j(res(i,j))) , r=1,2,...,ny-2*ky-1 +c ty(r+ky) <= y(j) <= ty(r+ky+1) + fp = 0. + do 490 i=1,nx + fpx(i) = 0. + 490 continue + do 500 i=1,ny + fpy(i) = 0. + 500 continue + nk1y = ny-ky1 + iz = 0 + nroldx = 0 +c main loop for the different grid points. + do 550 i1=1,mx + numx = nrx(i1) + numx1 = numx+1 + nroldy = 0 + do 540 i2=1,my + numy = nry(i2) + numy1 = numy+1 + iz = iz+1 +c evaluate s(x,y) at the current grid point by making the sum of the +c cross products of the non-zero b-splines at (x,y), multiplied with +c the appropriate b-spline coefficients. + term = 0. + k1 = numx*nk1y+numy + do 520 l1=1,kx1 + k2 = k1 + fac = spx(i1,l1) + do 510 l2=1,ky1 + k2 = k2+1 + term = term+fac*spy(i2,l2)*c(k2) + 510 continue + k1 = k1+nk1y + 520 continue +c calculate the squared residual at the current grid point. + term = (z(iz)-term)**2 +c adjust the different parameters. + fp = fp+term + fpx(numx1) = fpx(numx1)+term + fpy(numy1) = fpy(numy1)+term + fac = term*half + if(numy.eq.nroldy) go to 530 + fpy(numy1) = fpy(numy1)-fac + fpy(numy) = fpy(numy)+fac + 530 nroldy = numy + if(numx.eq.nroldx) go to 540 + fpx(numx1) = fpx(numx1)-fac + fpx(numx) = fpx(numx)+fac + 540 continue + nroldx = numx + 550 continue + return + end + diff --git a/fitpack/fpgrsp.f b/fitpack/fpgrsp.f new file mode 100644 index 0000000..5916831 --- /dev/null +++ b/fitpack/fpgrsp.f @@ -0,0 +1,658 @@ + recursive subroutine fpgrsp(ifsu,ifsv,ifbu,ifbv,iback,u,mu,v, + * mv,r,mr,dr,iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm, + * mvnu,spu,spv,right,q,au,av1,av2,bu,bv,a0,a1,b0,b1,c0,c1, + * cosi,nru,nrv) + implicit none +c .. +c ..scalar arguments.. + real*8 p,sq,fp + integer ifsu,ifsv,ifbu,ifbv,iback,mu,mv,mr,iop0,iop1,nu,nv,nc, + * mm,mvnu +c ..array arguments.. + real*8 u(mu),v(mv),r(mr),dr(6),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv) + *, + * spu(mu,4),spv(mv,4),right(mm),q(mvnu),au(nu,5),av1(nv,6),c0(nv), + * av2(nv,4),a0(2,mv),b0(2,nv),cosi(2,nv),bu(nu,5),bv(nv,5),c1(nv), + * a1(2,mv),b1(2,nv) + integer nru(mu),nrv(mv) +c ..local scalars.. + real*8 arg,co,dr01,dr02,dr03,dr11,dr12,dr13,fac,fac0,fac1,pinv,piv + *, + * si,term,one,three,half + integer i,ic,ii,ij,ik,iq,irot,it,ir,i0,i1,i2,i3,j,jj,jk,jper, + * j0,j1,k,k1,k2,l,l0,l1,l2,mvv,ncof,nrold,nroldu,nroldv,number, + * numu,numu1,numv,numv1,nuu,nu4,nu7,nu8,nu9,nv11,nv4,nv7,nv8,n1 +c ..local arrays.. + real*8 h(5),h1(5),h2(4) +c ..function references.. + integer min0 + real*8 cos,sin +c ..subroutine references.. +c fpback,fpbspl,fpgivs,fpcyt1,fpcyt2,fpdisc,fpbacp,fprota +c .. +c let +c | (spu) | | (spv) | +c (au) = | -------------- | (av) = | -------------- | +c | sqrt(1/p) (bu) | | sqrt(1/p) (bv) | +c +c | r ' 0 | +c q = | ------ | +c | 0 ' 0 | +c +c with c : the (nu-4) x (nv-4) matrix which contains the b-spline +c coefficients. +c r : the mu x mv matrix which contains the function values. +c spu,spv: the mu x (nu-4), resp. mv x (nv-4) observation matrices +c according to the least-squares problems in the u-,resp. +c v-direction. +c bu,bv : the (nu-7) x (nu-4),resp. (nv-7) x (nv-4) matrices +c containing the discontinuity jumps of the derivatives +c of the b-splines in the u-,resp.v-variable at the knots +c the b-spline coefficients of the smoothing spline are then calculated +c as the least-squares solution of the following over-determined linear +c system of equations +c +c (1) (av) c (au)' = q +c +c subject to the constraints +c +c (2) c(i,nv-3+j) = c(i,j), j=1,2,3 ; i=1,2,...,nu-4 +c +c (3) if iop0 = 0 c(1,j) = dr(1) +c iop0 = 1 c(1,j) = dr(1) +c c(2,j) = dr(1)+(dr(2)*cosi(1,j)+dr(3)*cosi(2,j))* +c tu(5)/3. = c0(j) , j=1,2,...nv-4 +c +c (4) if iop1 = 0 c(nu-4,j) = dr(4) +c iop1 = 1 c(nu-4,j) = dr(4) +c c(nu-5,j) = dr(4)+(dr(5)*cosi(1,j)+dr(6)*cosi(2,j)) +c *(tu(nu-4)-tu(nu-3))/3. = c1(j) +c +c set constants + one = 1 + three = 3 + half = 0.5 +c initialization + nu4 = nu-4 + nu7 = nu-7 + nu8 = nu-8 + nu9 = nu-9 + nv4 = nv-4 + nv7 = nv-7 + nv8 = nv-8 + nv11 = nv-11 + nuu = nu4-iop0-iop1-2 + if(p.gt.0.) pinv = one/p +c it depends on the value of the flags ifsu,ifsv,ifbu,ifbv,iop0,iop1 +c and on the value of p whether the matrices (spu), (spv), (bu), (bv), +c (cosi) still must be determined. + if(ifsu.ne.0) go to 30 +c calculate the non-zero elements of the matrix (spu) which is the ob- +c servation matrix according to the least-squares spline approximation +c problem in the u-direction. + l = 4 + l1 = 5 + number = 0 + do 25 it=1,mu + arg = u(it) + 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 15 + l = l1 + l1 = l+1 + number = number+1 + go to 10 + 15 call fpbspl(tu,nu,3,arg,l,h) + do 20 i=1,4 + spu(it,i) = h(i) + 20 continue + nru(it) = number + 25 continue + ifsu = 1 +c calculate the non-zero elements of the matrix (spv) which is the ob- +c servation matrix according to the least-squares spline approximation +c problem in the v-direction. + 30 if(ifsv.ne.0) go to 85 + l = 4 + l1 = 5 + number = 0 + do 50 it=1,mv + arg = v(it) + 35 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 40 + l = l1 + l1 = l+1 + number = number+1 + go to 35 + 40 call fpbspl(tv,nv,3,arg,l,h) + do 45 i=1,4 + spv(it,i) = h(i) + 45 continue + nrv(it) = number + 50 continue + ifsv = 1 + if(iop0.eq.0 .and. iop1.eq.0) go to 85 +c calculate the coefficients of the interpolating splines for cos(v) +c and sin(v). + do 55 i=1,nv4 + cosi(1,i) = 0. + cosi(2,i) = 0. + 55 continue + if(nv7.lt.4) go to 85 + do 65 i=1,nv7 + l = i+3 + arg = tv(l) + call fpbspl(tv,nv,3,arg,l,h) + do 60 j=1,3 + av1(i,j) = h(j) + 60 continue + cosi(1,i) = cos(arg) + cosi(2,i) = sin(arg) + 65 continue + call fpcyt1(av1,nv7,nv) + do 80 j=1,2 + do 70 i=1,nv7 + right(i) = cosi(j,i) + 70 continue + call fpcyt2(av1,nv7,right,right,nv) + do 75 i=1,nv7 + cosi(j,i+1) = right(i) + 75 continue + cosi(j,1) = cosi(j,nv7+1) + cosi(j,nv7+2) = cosi(j,2) + cosi(j,nv4) = cosi(j,3) + 80 continue + 85 if(p.le.0.) go to 150 +c calculate the non-zero elements of the matrix (bu). + if(ifbu.ne.0 .or. nu8.eq.0) go to 90 + call fpdisc(tu,nu,5,bu,nu) + ifbu = 1 +c calculate the non-zero elements of the matrix (bv). + 90 if(ifbv.ne.0 .or. nv8.eq.0) go to 150 + call fpdisc(tv,nv,5,bv,nv) + ifbv = 1 +c substituting (2),(3) and (4) into (1), we obtain the overdetermined +c system +c (5) (avv) (cc) (auu)' = (qq) +c from which the nuu*nv7 remaining coefficients +c c(i,j) , i=2+iop0,3+iop0,...,nu-5-iop1,j=1,2,...,nv-7. +c the elements of (cc), are then determined in the least-squares sense. +c simultaneously, we compute the resulting sum of squared residuals sq. + 150 dr01 = dr(1) + dr11 = dr(4) + do 155 i=1,mv + a0(1,i) = dr01 + a1(1,i) = dr11 + 155 continue + if(nv8.eq.0 .or. p.le.0.) go to 165 + do 160 i=1,nv8 + b0(1,i) = 0. + b1(1,i) = 0. + 160 continue + 165 mvv = mv + if(iop0.eq.0) go to 195 + fac = (tu(5)-tu(4))/three + dr02 = dr(2)*fac + dr03 = dr(3)*fac + do 170 i=1,nv4 + c0(i) = dr01+dr02*cosi(1,i)+dr03*cosi(2,i) + 170 continue + do 180 i=1,mv + number = nrv(i) + fac = 0. + do 175 j=1,4 + number = number+1 + fac = fac+c0(number)*spv(i,j) + 175 continue + a0(2,i) = fac + 180 continue + if(nv8.eq.0 .or. p.le.0.) go to 195 + do 190 i=1,nv8 + number = i + fac = 0. + do 185 j=1,5 + fac = fac+c0(number)*bv(i,j) + number = number+1 + 185 continue + b0(2,i) = fac*pinv + 190 continue + mvv = mv+nv8 + 195 if(iop1.eq.0) go to 225 + fac = (tu(nu4)-tu(nu4+1))/three + dr12 = dr(5)*fac + dr13 = dr(6)*fac + do 200 i=1,nv4 + c1(i) = dr11+dr12*cosi(1,i)+dr13*cosi(2,i) + 200 continue + do 210 i=1,mv + number = nrv(i) + fac = 0. + do 205 j=1,4 + number = number+1 + fac = fac+c1(number)*spv(i,j) + 205 continue + a1(2,i) = fac + 210 continue + if(nv8.eq.0 .or. p.le.0.) go to 225 + do 220 i=1,nv8 + number = i + fac = 0. + do 215 j=1,5 + fac = fac+c1(number)*bv(i,j) + number = number+1 + 215 continue + b1(2,i) = fac*pinv + 220 continue + mvv = mv+nv8 +c we first determine the matrices (auu) and (qq). then we reduce the +c matrix (auu) to an unit upper triangular form (ru) using givens +c rotations without square roots. we apply the same transformations to +c the rows of matrix qq to obtain the mv x nuu matrix g. +c we store matrix (ru) into au and g into q. + 225 l = mvv*nuu +c initialization. + sq = 0. + if(l.eq.0) go to 245 + do 230 i=1,l + q(i) = 0. + 230 continue + do 240 i=1,nuu + do 240 j=1,5 + au(i,j) = 0. + 240 continue + l = 0 + 245 nrold = 0 + n1 = nrold+1 + do 420 it=1,mu + number = nru(it) +c find the appropriate column of q. + 250 do 260 j=1,mvv + right(j) = 0. + 260 continue + if(nrold.eq.number) go to 280 + if(p.le.0.) go to 410 +c fetch a new row of matrix (bu). + do 270 j=1,5 + h(j) = bu(n1,j)*pinv + 270 continue + i0 = 1 + i1 = 5 + go to 310 +c fetch a new row of matrix (spu). + 280 do 290 j=1,4 + h(j) = spu(it,j) + 290 continue +c find the appropriate column of q. + do 300 j=1,mv + l = l+1 + right(j) = r(l) + 300 continue + i0 = 1 + i1 = 4 + 310 j0 = n1 + j1 = nu7-number +c take into account that we eliminate the constraints (3) + 315 if(j0-1.gt.iop0) go to 335 + fac0 = h(i0) + do 320 j=1,mv + right(j) = right(j)-fac0*a0(j0,j) + 320 continue + if(mv.eq.mvv) go to 330 + j = mv + do 325 jj=1,nv8 + j = j+1 + right(j) = right(j)-fac0*b0(j0,jj) + 325 continue + 330 j0 = j0+1 + i0 = i0+1 + go to 315 +c take into account that we eliminate the constraints (4) + 335 if(j1-1.gt.iop1) go to 360 + fac1 = h(i1) + do 340 j=1,mv + right(j) = right(j)-fac1*a1(j1,j) + 340 continue + if(mv.eq.mvv) go to 350 + j = mv + do 345 jj=1,nv8 + j = j+1 + right(j) = right(j)-fac1*b1(j1,jj) + 345 continue + 350 j1 = j1+1 + i1 = i1-1 + go to 335 + 360 irot = nrold-iop0-1 + if(irot.lt.0) irot = 0 +c rotate the new row of matrix (auu) into triangle. + if(i0.gt.i1) go to 390 + do 385 i=i0,i1 + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 385 +c calculate the parameters of the givens transformation. + call fpgivs(piv,au(irot,1),co,si) +c apply that transformation to the rows of matrix (qq). + iq = (irot-1)*mvv + do 370 j=1,mvv + iq = iq+1 + call fprota(co,si,right(j),q(iq)) + 370 continue +c apply that transformation to the columns of (auu). + if(i.eq.i1) go to 385 + i2 = 1 + i3 = i+1 + do 380 j=i3,i1 + i2 = i2+1 + call fprota(co,si,h(j),au(irot,i2)) + 380 continue + 385 continue +c we update the sum of squared residuals. + 390 do 395 j=1,mvv + sq = sq+right(j)**2 + 395 continue + if(nrold.eq.number) go to 420 + 410 nrold = n1 + n1 = n1+1 + go to 250 + 420 continue + if(nuu.eq.0) go to 800 +c we determine the matrix (avv) and then we reduce her to an unit +c upper triangular form (rv) using givens rotations without square +c roots. we apply the same transformations to the columns of matrix +c g to obtain the (nv-7) x (nu-6-iop0-iop1) matrix h. +c we store matrix (rv) into av1 and av2, h into c. +c the nv7 x nv7 triangular unit upper matrix (rv) has the form +c | av1 ' | +c (rv) = | ' av2 | +c | 0 ' | +c with (av2) a nv7 x 4 matrix and (av1) a nv11 x nv11 unit upper +c triangular matrix of bandwidth 5. + ncof = nuu*nv7 +c initialization. + do 430 i=1,ncof + c(i) = 0. + 430 continue + do 440 i=1,nv4 + av1(i,5) = 0. + do 440 j=1,4 + av1(i,j) = 0. + av2(i,j) = 0. + 440 continue + jper = 0 + nrold = 0 + do 770 it=1,mv + number = nrv(it) + 450 if(nrold.eq.number) go to 480 + if(p.le.0.) go to 760 +c fetch a new row of matrix (bv). + n1 = nrold+1 + do 460 j=1,5 + h(j) = bv(n1,j)*pinv + 460 continue +c find the appropriate row of g. + do 465 j=1,nuu + right(j) = 0. + 465 continue + if(mv.eq.mvv) go to 510 + l = mv+n1 + do 470 j=1,nuu + right(j) = q(l) + l = l+mvv + 470 continue + go to 510 +c fetch a new row of matrix (spv) + 480 h(5) = 0. + do 490 j=1,4 + h(j) = spv(it,j) + 490 continue +c find the appropriate row of g. + l = it + do 500 j=1,nuu + right(j) = q(l) + l = l+mvv + 500 continue +c test whether there are non-zero values in the new row of (avv) +c corresponding to the b-splines n(j;v),j=nv7+1,...,nv4. + 510 if(nrold.lt.nv11) go to 710 + if(jper.ne.0) go to 550 +c initialize the matrix (av2). + jk = nv11+1 + do 540 i=1,4 + ik = jk + do 520 j=1,5 + if(ik.le.0) go to 530 + av2(ik,i) = av1(ik,j) + ik = ik-1 + 520 continue + 530 jk = jk+1 + 540 continue + jper = 1 +c if one of the non-zero elements of the new row corresponds to one of +c the b-splines n(j;v),j=nv7+1,...,nv4, we take account of condition +c (2) for setting up this row of (avv). the row is stored in h1( the +c part with respect to av1) and h2 (the part with respect to av2). + 550 do 560 i=1,4 + h1(i) = 0. + h2(i) = 0. + 560 continue + h1(5) = 0. + j = nrold-nv11 + do 600 i=1,5 + j = j+1 + l0 = j + 570 l1 = l0-4 + if(l1.le.0) go to 590 + if(l1.le.nv11) go to 580 + l0 = l1-nv11 + go to 570 + 580 h1(l1) = h(i) + go to 600 + 590 h2(l0) = h2(l0) + h(i) + 600 continue +c rotate the new row of (avv) into triangle. + if(nv11.le.0) go to 670 +c rotations with the rows 1,2,...,nv11 of (avv). + do 660 j=1,nv11 + piv = h1(1) + i2 = min0(nv11-j,4) + if(piv.eq.0.) go to 640 +c calculate the parameters of the givens transformation. + call fpgivs(piv,av1(j,1),co,si) +c apply that transformation to the columns of matrix g. + ic = j + do 610 i=1,nuu + call fprota(co,si,right(i),c(ic)) + ic = ic+nv7 + 610 continue +c apply that transformation to the rows of (avv) with respect to av2. + do 620 i=1,4 + call fprota(co,si,h2(i),av2(j,i)) + 620 continue +c apply that transformation to the rows of (avv) with respect to av1. + if(i2.eq.0) go to 670 + do 630 i=1,i2 + i1 = i+1 + call fprota(co,si,h1(i1),av1(j,i1)) + 630 continue + 640 do 650 i=1,i2 + h1(i) = h1(i+1) + 650 continue + h1(i2+1) = 0. + 660 continue +c rotations with the rows nv11+1,...,nv7 of avv. + 670 do 700 j=1,4 + ij = nv11+j + if(ij.le.0) go to 700 + piv = h2(j) + if(piv.eq.0.) go to 700 +c calculate the parameters of the givens transformation. + call fpgivs(piv,av2(ij,j),co,si) +c apply that transformation to the columns of matrix g. + ic = ij + do 680 i=1,nuu + call fprota(co,si,right(i),c(ic)) + ic = ic+nv7 + 680 continue + if(j.eq.4) go to 700 +c apply that transformation to the rows of (avv) with respect to av2. + j1 = j+1 + do 690 i=j1,4 + call fprota(co,si,h2(i),av2(ij,i)) + 690 continue + 700 continue +c we update the sum of squared residuals. + do 705 i=1,nuu + sq = sq+right(i)**2 + 705 continue + go to 750 +c rotation into triangle of the new row of (avv), in case the elements +c corresponding to the b-splines n(j;v),j=nv7+1,...,nv4 are all zero. + 710 irot =nrold + do 740 i=1,5 + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 740 +c calculate the parameters of the givens transformation. + call fpgivs(piv,av1(irot,1),co,si) +c apply that transformation to the columns of matrix g. + ic = irot + do 720 j=1,nuu + call fprota(co,si,right(j),c(ic)) + ic = ic+nv7 + 720 continue +c apply that transformation to the rows of (avv). + if(i.eq.5) go to 740 + i2 = 1 + i3 = i+1 + do 730 j=i3,5 + i2 = i2+1 + call fprota(co,si,h(j),av1(irot,i2)) + 730 continue + 740 continue +c we update the sum of squared residuals. + do 745 i=1,nuu + sq = sq+right(i)**2 + 745 continue + 750 if(nrold.eq.number) go to 770 + 760 nrold = nrold+1 + go to 450 + 770 continue +c test whether the b-spline coefficients must be determined. + if(iback.ne.0) return +c backward substitution to obtain the b-spline coefficients as the +c solution of the linear system (rv) (cr) (ru)' = h. +c first step: solve the system (rv) (c1) = h. + k = 1 + do 780 i=1,nuu + call fpbacp(av1,av2,c(k),nv7,4,c(k),5,nv) + k = k+nv7 + 780 continue +c second step: solve the system (cr) (ru)' = (c1). + k = 0 + do 795 j=1,nv7 + k = k+1 + l = k + do 785 i=1,nuu + right(i) = c(l) + l = l+nv7 + 785 continue + call fpback(au,right,nuu,5,right,nu) + l = k + do 790 i=1,nuu + c(l) = right(i) + l = l+nv7 + 790 continue + 795 continue +c calculate from the conditions (2)-(3)-(4), the remaining b-spline +c coefficients. + 800 ncof = nu4*nv4 + j = ncof + do 805 l=1,nv4 + q(l) = dr01 + q(j) = dr11 + j = j-1 + 805 continue + i = nv4 + j = 0 + if(iop0.eq.0) go to 815 + do 810 l=1,nv4 + i = i+1 + q(i) = c0(l) + 810 continue + 815 if(nuu.eq.0) go to 835 + do 830 l=1,nuu + ii = i + do 820 k=1,nv7 + i = i+1 + j = j+1 + q(i) = c(j) + 820 continue + do 825 k=1,3 + ii = ii+1 + i = i+1 + q(i) = q(ii) + 825 continue + 830 continue + 835 if(iop1.eq.0) go to 845 + do 840 l=1,nv4 + i = i+1 + q(i) = c1(l) + 840 continue + 845 do 850 i=1,ncof + c(i) = q(i) + 850 continue +c calculate the quantities +c res(i,j) = (r(i,j) - s(u(i),v(j)))**2 , i=1,2,..,mu;j=1,2,..,mv +c fp = sumi=1,mu(sumj=1,mv(res(i,j))) +c fpu(r) = sum''i(sumj=1,mv(res(i,j))) , r=1,2,...,nu-7 +c tu(r+3) <= u(i) <= tu(r+4) +c fpv(r) = sumi=1,mu(sum''j(res(i,j))) , r=1,2,...,nv-7 +c tv(r+3) <= v(j) <= tv(r+4) + fp = 0. + do 890 i=1,nu + fpu(i) = 0. + 890 continue + do 900 i=1,nv + fpv(i) = 0. + 900 continue + ir = 0 + nroldu = 0 +c main loop for the different grid points. + do 950 i1=1,mu + numu = nru(i1) + numu1 = numu+1 + nroldv = 0 + do 940 i2=1,mv + numv = nrv(i2) + numv1 = numv+1 + ir = ir+1 +c evaluate s(u,v) at the current grid point by making the sum of the +c cross products of the non-zero b-splines at (u,v), multiplied with +c the appropriate b-spline coefficients. + term = 0. + k1 = numu*nv4+numv + do 920 l1=1,4 + k2 = k1 + fac = spu(i1,l1) + do 910 l2=1,4 + k2 = k2+1 + term = term+fac*spv(i2,l2)*c(k2) + 910 continue + k1 = k1+nv4 + 920 continue +c calculate the squared residual at the current grid point. + term = (r(ir)-term)**2 +c adjust the different parameters. + fp = fp+term + fpu(numu1) = fpu(numu1)+term + fpv(numv1) = fpv(numv1)+term + fac = term*half + if(numv.eq.nroldv) go to 930 + fpv(numv1) = fpv(numv1)-fac + fpv(numv) = fpv(numv)+fac + 930 nroldv = numv + if(numu.eq.nroldu) go to 940 + fpu(numu1) = fpu(numu1)-fac + fpu(numu) = fpu(numu)+fac + 940 continue + nroldu = numu + 950 continue + return + end diff --git a/fitpack/fpinst.f b/fitpack/fpinst.f new file mode 100644 index 0000000..2c0ef5c --- /dev/null +++ b/fitpack/fpinst.f @@ -0,0 +1,78 @@ + recursive subroutine fpinst(iopt,t,n,c,k,x,l,tt,nn,cc,nest) + implicit none +c given the b-spline representation (knots t(j),j=1,2,...,n, b-spline +c coefficients c(j),j=1,2,...,n-k-1) of a spline of degree k, fpinst +c calculates the b-spline representation (knots tt(j),j=1,2,...,nn, +c b-spline coefficients cc(j),j=1,2,...,nn-k-1) of the same spline if +c an additional knot is inserted at the point x situated in the inter- +c val t(l)<=x2*k or l0) in such a way that +c - if p tends to infinity, sp(u,v) becomes the least-squares spline +c with given knots, satisfying the constraints. +c - if p tends to zero, sp(u,v) becomes the least-squares polynomial, +c satisfying the constraints. +c - the function f(p)=sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2) +c is continuous and strictly decreasing for p>0. +c +c ..scalar arguments.. + integer ifsu,ifsv,ifbu,ifbv,mu,mv,mz,nu,nv,nuest,nvest, + * nc,lwrk + real*8 z0,p,step,fp +c ..array arguments.. + integer ider(2),nru(mu),nrv(mv),iopt(3) + real*8 u(mu),v(mv),z(mz),dz(3),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv) + *, + * wrk(lwrk) +c ..local scalars.. + real*8 res,sq,sqq,step1,step2,three + integer i,id0,iop0,iop1,i1,j,l,laa,lau,lav1,lav2,lbb,lbu,lbv, + * lcc,lcs,lq,lri,lsu,lsv,l1,l2,mm,mvnu,number +c ..local arrays.. + integer nr(3) + real*8 delta(3),dzz(3),sum(3),a(6,6),g(6) +c ..function references.. + integer max0 +c ..subroutine references.. +c fpgrdi,fpsysy +c .. +c set constant + three = 3 +c we partition the working space + lsu = 1 + lsv = lsu+4*mu + lri = lsv+4*mv + mm = max0(nuest,mv+nvest) + lq = lri+mm + mvnu = nuest*(mv+nvest-8) + lau = lq+mvnu + lav1 = lau+5*nuest + lav2 = lav1+6*nvest + lbu = lav2+4*nvest + lbv = lbu+5*nuest + laa = lbv+5*nvest + lbb = laa+2*mv + lcc = lbb+2*nvest + lcs = lcc+nvest +c we calculate the smoothing spline sp(u,v) according to the input +c values dz(i),i=1,2,3. + iop0 = iopt(2) + iop1 = iopt(3) + call fpgrdi(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,z,mz,dz, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), + * wrk(lcc),wrk(lcs),nru,nrv) + id0 = ider(1) + if(id0.ne.0) go to 5 + res = (z0-dz(1))**2 + fp = fp+res + sq = sq+res +c in case all derivative values dz(i) are given (step<=0) or in case +c we have spline interpolation, we accept this spline as a solution. + 5 if(step.le.0. .or. sq.le.0.) return + dzz(1) = dz(1) + dzz(2) = dz(2) + dzz(3) = dz(3) +c number denotes the number of derivative values dz(i) that still must +c be optimized. let us denote these parameters by g(j),j=1,...,number. + number = 0 + if(id0.gt.0) go to 10 + number = 1 + nr(1) = 1 + delta(1) = step + 10 if(iop0.eq.0) go to 20 + if(ider(2).ne.0) go to 20 + step2 = step*three/tu(5) + nr(number+1) = 2 + nr(number+2) = 3 + delta(number+1) = step2 + delta(number+2) = step2 + number = number+2 + 20 if(number.eq.0) return +c the sum of squared residuals sq is a quadratic polynomial in the +c parameters g(j). we determine the unknown coefficients of this +c polymomial by calculating (number+1)*(number+2)/2 different splines +c according to specific values for g(j). + do 30 i=1,number + l = nr(i) + step1 = delta(i) + dzz(l) = dz(l)+step1 + call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sum(i),fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), + * wrk(lcc),wrk(lcs),nru,nrv) + if(id0.eq.0) sum(i) = sum(i)+(z0-dzz(1))**2 + dzz(l) = dz(l)-step1 + call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), + * wrk(lcc),wrk(lcs),nru,nrv) + if(id0.eq.0) sqq = sqq+(z0-dzz(1))**2 + a(i,i) = (sum(i)+sqq-sq-sq)/step1**2 + if(a(i,i).le.0.) go to 80 + g(i) = (sqq-sum(i))/(step1+step1) + dzz(l) = dz(l) + 30 continue + if(number.eq.1) go to 60 + do 50 i=2,number + l1 = nr(i) + step1 = delta(i) + dzz(l1) = dz(l1)+step1 + i1 = i-1 + do 40 j=1,i1 + l2 = nr(j) + step2 = delta(j) + dzz(l2) = dz(l2)+step2 + call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), + * wrk(lcc),wrk(lcs),nru,nrv) + if(id0.eq.0) sqq = sqq+(z0-dzz(1))**2 + a(i,j) = (sq+sqq-sum(i)-sum(j))/(step1*step2) + dzz(l2) = dz(l2) + 40 continue + dzz(l1) = dz(l1) + 50 continue +c the optimal values g(j) are found as the solution of the system +c d (sq) / d (g(j)) = 0 , j=1,...,number. + 60 call fpsysy(a,number,g) + do 70 i=1,number + l = nr(i) + dz(l) = dz(l)+g(i) + 70 continue +c we determine the spline sp(u,v) according to the optimal values g(j). + 80 call fpgrdi(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,z,mz,dz, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), + * wrk(lcc),wrk(lcs),nru,nrv) + if(id0.eq.0) fp = fp+(z0-dz(1))**2 + return + end diff --git a/fitpack/fpopsp.f b/fitpack/fpopsp.f new file mode 100644 index 0000000..628598a --- /dev/null +++ b/fitpack/fpopsp.f @@ -0,0 +1,212 @@ + recursive subroutine fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r, + * mr,r0,r1,dr,iopt,ider,tu,nu,tv,nv,nuest,nvest,p,step,c,nc, + * fp,fpu,fpv,nru,nrv,wrk,lwrk) + implicit none +c given the set of function values r(i,j) defined on the rectangular +c grid (u(i),v(j)),i=1,2,...,mu;j=1,2,...,mv, fpopsp determines a +c smooth bicubic spline approximation with given knots tu(i),i=1,..,nu +c in the u-direction and tv(j),j=1,2,...,nv in the v-direction. this +c spline sp(u,v) will be periodic in the variable v and will satisfy +c the following constraints +c +c s(tu(1),v) = dr(1) , tv(4) <=v<= tv(nv-3) +c +c s(tu(nu),v) = dr(4) , tv(4) <=v<= tv(nv-3) +c +c and (if iopt(2) = 1) +c +c d s(tu(1),v) +c ------------ = dr(2)*cos(v)+dr(3)*sin(v) , tv(4) <=v<= tv(nv-3) +c d u +c +c and (if iopt(3) = 1) +c +c d s(tu(nu),v) +c ------------- = dr(5)*cos(v)+dr(6)*sin(v) , tv(4) <=v<= tv(nv-3) +c d u +c +c where the parameters dr(i) correspond to the derivative values at the +c poles as defined in subroutine spgrid. +c +c the b-spline coefficients of sp(u,v) are determined as the least- +c squares solution of an overdetermined linear system which depends +c on the value of p and on the values dr(i),i=1,...,6. the correspond- +c ing sum of squared residuals sq is a simple quadratic function in +c the variables dr(i). these may or may not be provided. the values +c dr(i) which are not given will be determined so as to minimize the +c resulting sum of squared residuals sq. in that case the user must +c provide some initial guess dr(i) and some estimate (dr(i)-step, +c dr(i)+step) of the range of possible values for these latter. +c +c sp(u,v) also depends on the parameter p (p>0) in such a way that +c - if p tends to infinity, sp(u,v) becomes the least-squares spline +c with given knots, satisfying the constraints. +c - if p tends to zero, sp(u,v) becomes the least-squares polynomial, +c satisfying the constraints. +c - the function f(p)=sumi=1,mu(sumj=1,mv((r(i,j)-sp(u(i),v(j)))**2) +c is continuous and strictly decreasing for p>0. +c +c ..scalar arguments.. + integer ifsu,ifsv,ifbu,ifbv,mu,mv,mr,nu,nv,nuest,nvest, + * nc,lwrk + real*8 r0,r1,p,fp +c ..array arguments.. + integer ider(4),nru(mu),nrv(mv),iopt(3) + real*8 u(mu),v(mv),r(mr),dr(6),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv) + *, + * wrk(lwrk),step(2) +c ..local scalars.. + real*8 sq,sqq,sq0,sq1,step1,step2,three + integer i,id0,iop0,iop1,i1,j,l,lau,lav1,lav2,la0,la1,lbu,lbv,lb0, + * lb1,lc0,lc1,lcs,lq,lri,lsu,lsv,l1,l2,mm,mvnu,number, id1 +c ..local arrays.. + integer nr(6) + real*8 delta(6),drr(6),sum(6),a(6,6),g(6) +c ..function references.. + integer max0 +c ..subroutine references.. +c fpgrsp,fpsysy +c .. +c set constant + three = 3 +c we partition the working space + lsu = 1 + lsv = lsu+4*mu + lri = lsv+4*mv + mm = max0(nuest,mv+nvest) + lq = lri+mm + mvnu = nuest*(mv+nvest-8) + lau = lq+mvnu + lav1 = lau+5*nuest + lav2 = lav1+6*nvest + lbu = lav2+4*nvest + lbv = lbu+5*nuest + la0 = lbv+5*nvest + la1 = la0+2*mv + lb0 = la1+2*mv + lb1 = lb0+2*nvest + lc0 = lb1+2*nvest + lc1 = lc0+nvest + lcs = lc1+nvest +c we calculate the smoothing spline sp(u,v) according to the input +c values dr(i),i=1,...,6. + iop0 = iopt(2) + iop1 = iopt(3) + id0 = ider(1) + id1 = ider(3) + call fpgrsp(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,r,mr,dr, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), + * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) + sq0 = 0. + sq1 = 0. + if(id0.eq.0) sq0 = (r0-dr(1))**2 + if(id1.eq.0) sq1 = (r1-dr(4))**2 + sq = sq+sq0+sq1 +c in case all derivative values dr(i) are given (step<=0) or in case +c we have spline interpolation, we accept this spline as a solution. + if(sq.le.0.) return + if(step(1).le.0. .and. step(2).le.0.) return + do 10 i=1,6 + drr(i) = dr(i) + 10 continue +c number denotes the number of derivative values dr(i) that still must +c be optimized. let us denote these parameters by g(j),j=1,...,number. + number = 0 + if(id0.gt.0) go to 20 + number = 1 + nr(1) = 1 + delta(1) = step(1) + 20 if(iop0.eq.0) go to 30 + if(ider(2).ne.0) go to 30 + step2 = step(1)*three/(tu(5)-tu(4)) + nr(number+1) = 2 + nr(number+2) = 3 + delta(number+1) = step2 + delta(number+2) = step2 + number = number+2 + 30 if(id1.gt.0) go to 40 + number = number+1 + nr(number) = 4 + delta(number) = step(2) + 40 if(iop1.eq.0) go to 50 + if(ider(4).ne.0) go to 50 + step2 = step(2)*three/(tu(nu)-tu(nu-4)) + nr(number+1) = 5 + nr(number+2) = 6 + delta(number+1) = step2 + delta(number+2) = step2 + number = number+2 + 50 if(number.eq.0) return +c the sum of squared residulas sq is a quadratic polynomial in the +c parameters g(j). we determine the unknown coefficients of this +c polymomial by calculating (number+1)*(number+2)/2 different splines +c according to specific values for g(j). + do 60 i=1,number + l = nr(i) + step1 = delta(i) + drr(l) = dr(l)+step1 + call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sum(i),fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), + * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) + if(id0.eq.0) sq0 = (r0-drr(1))**2 + if(id1.eq.0) sq1 = (r1-drr(4))**2 + sum(i) = sum(i)+sq0+sq1 + drr(l) = dr(l)-step1 + call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), + * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) + if(id0.eq.0) sq0 = (r0-drr(1))**2 + if(id1.eq.0) sq1 = (r1-drr(4))**2 + sqq = sqq+sq0+sq1 + drr(l) = dr(l) + a(i,i) = (sum(i)+sqq-sq-sq)/step1**2 + if(a(i,i).le.0.) go to 110 + g(i) = (sqq-sum(i))/(step1+step1) + 60 continue + if(number.eq.1) go to 90 + do 80 i=2,number + l1 = nr(i) + step1 = delta(i) + drr(l1) = dr(l1)+step1 + i1 = i-1 + do 70 j=1,i1 + l2 = nr(j) + step2 = delta(j) + drr(l2) = dr(l2)+step2 + call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), + * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) + if(id0.eq.0) sq0 = (r0-drr(1))**2 + if(id1.eq.0) sq1 = (r1-drr(4))**2 + sqq = sqq+sq0+sq1 + a(i,j) = (sq+sqq-sum(i)-sum(j))/(step1*step2) + drr(l2) = dr(l2) + 70 continue + drr(l1) = dr(l1) + 80 continue +c the optimal values g(j) are found as the solution of the system +c d (sq) / d (g(j)) = 0 , j=1,...,number. + 90 call fpsysy(a,number,g) + do 100 i=1,number + l = nr(i) + dr(l) = dr(l)+g(i) + 100 continue +c we determine the spline sp(u,v) according to the optimal values g(j). + 110 call fpgrsp(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,r,mr,dr, + * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu, + * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), + * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), + * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) + if(id0.eq.0) sq0 = (r0-dr(1))**2 + if(id1.eq.0) sq1 = (r1-dr(4))**2 + sq = sq+sq0+sq1 + return + end diff --git a/fitpack/fporde.f b/fitpack/fporde.f new file mode 100644 index 0000000..5d05489 --- /dev/null +++ b/fitpack/fporde.f @@ -0,0 +1,48 @@ + recursive subroutine fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer, + * index,nreg) +c subroutine fporde sorts the data points (x(i),y(i)),i=1,2,...,m +c according to the panel tx(l)<=x s we will increase the number of knots and compute the c +c corresponding least-squares curve until finally fp<=s. c +c the initial choice of knots depends on the value of s and iopt. c +c if s=0 we have spline interpolation; in that case the number of c +c knots equals nmax = m+k+1. c +c if s > 0 and c +c iopt=0 we first compute the least-squares polynomial curve of c +c degree k; n = nmin = 2*k+2 c +c iopt=1 we start with the set of knots found at the last c +c call of the routine, except for the case that s > fp0; then c +c we compute directly the polynomial curve of degree k. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c determine nmin, the number of knots for polynomial approximation. + nmin = 2*k1 + if(iopt.lt.0) go to 60 +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s +c determine nmax, the number of knots for spline interpolation. + nmax = m+k1 + if(s.gt.0.) go to 45 +c if s=0, s(u) is an interpolating curve. +c test whether the required storage space exceeds the available one. + n = nmax + if(nmax.gt.nest) go to 420 +c find the position of the interior knots in case of interpolation. + 10 mk1 = m-k1 + if(mk1.eq.0) go to 60 + k3 = k/2 + i = k2 + j = k3+2 + if(k3*2.eq.k) go to 30 + do 20 l=1,mk1 + t(i) = u(j) + i = i+1 + j = j+1 + 20 continue + go to 60 + 30 do 40 l=1,mk1 + t(i) = (u(j)+u(j-1))*half + i = i+1 + j = j+1 + 40 continue + go to 60 +c if s>0 our initial choice of knots depends on the value of iopt. +c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +c polynomial curve which is a spline curve without interior knots. +c if iopt=1 and fp0>s we start computing the least squares spline curve +c according to the set of knots found at the last call of the routine. + 45 if(iopt.eq.0) go to 50 + if(n.eq.nmin) go to 50 + fp0 = fpint(n) + fpold = fpint(n-1) + nplus = nrdata(n) + if(fp0.gt.s) go to 60 + 50 n = nmin + fpold = 0. + nplus = 0 + nrdata(1) = m-2 +c main loop for the different sets of knots. m is a save upper bound +c for the number of trials. + 60 do 200 iter = 1,m + if(n.eq.nmin) ier = -2 +c find nrint, tne number of knot intervals. + nrint = n-nmin+1 +c find the position of the additional knots which are needed for +c the b-spline representation of s(u). + nk1 = n-k1 + i = n + do 70 j=1,k1 + t(j) = ub + t(i) = ue + i = i-1 + 70 continue +c compute the b-spline coefficients of the least-squares spline curve +c sinf(u). the observation matrix a is built up row by row and +c reduced to upper triangular form by givens transformations. +c at the same time fp=f(p=inf) is computed. + fp = 0. +c initialize the b-spline coefficients and the observation matrix a. + do 75 i=1,nc + z(i) = 0. + 75 continue + do 80 i=1,nk1 + do 80 j=1,k1 + a(i,j) = 0. + 80 continue + l = k1 + jj = 0 + do 130 it=1,m +c fetch the current data point u(it),x(it). + ui = u(it) + wi = w(it) + do 83 j=1,idim + jj = jj+1 + xi(j) = x(jj)*wi + 83 continue +c search for knot interval t(l) <= ui < t(l+1). + 85 if(ui.lt.t(l+1) .or. l.eq.nk1) go to 90 + l = l+1 + go to 85 +c evaluate the (k+1) non-zero b-splines at ui and store them in q. + 90 call fpbspl(t,n,k,ui,l,h) + do 95 i=1,k1 + q(it,i) = h(i) + h(i) = h(i)*wi + 95 continue +c rotate the new row of the observation matrix into triangle. + j = l-k1 + do 110 i=1,k1 + j = j+1 + piv = h(i) + if(piv.eq.0.) go to 110 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(j,1),cos,sin) +c transformations to right hand side. + j1 = j + do 97 j2 =1,idim + call fprota(cos,sin,xi(j2),z(j1)) + j1 = j1+n + 97 continue + if(i.eq.k1) go to 120 + i2 = 1 + i3 = i+1 + do 100 i1 = i3,k1 + i2 = i2+1 +c transformations to left hand side. + call fprota(cos,sin,h(i1),a(j,i2)) + 100 continue + 110 continue +c add contribution of this row to the sum of squares of residual +c right hand sides. + 120 do 125 j2=1,idim + fp = fp+xi(j2)**2 + 125 continue + 130 continue + if(ier.eq.(-2)) fp0 = fp + fpint(n) = fp0 + fpint(n-1) = fpold + nrdata(n) = nplus +c backward substitution to obtain the b-spline coefficients. + j1 = 1 + do 135 j2=1,idim + call fpback(a,z(j1),nk1,k1,c(j1),nest) + j1 = j1+n + 135 continue +c test whether the approximation sinf(u) is an acceptable solution. + if(iopt.lt.0) go to 440 + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c if f(p=inf) < s accept the choice of knots. + if(fpms.lt.0.) go to 250 +c if n = nmax, sinf(u) is an interpolating spline curve. + if(n.eq.nmax) go to 430 +c increase the number of knots. +c if n=nest we cannot increase the number of knots because of +c the storage capacity limitation. + if(n.eq.nest) go to 420 +c determine the number of knots nplus we are going to add. + if(ier.eq.0) go to 140 + nplus = 1 + ier = 0 + go to 150 + 140 npl1 = nplus*2 + rn = nplus + if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) + nplus = min0(nplus*2,max0(npl1,nplus/2,1)) + 150 fpold = fp +c compute the sum of squared residuals for each knot interval +c t(j+k) <= u(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. + fpart = 0. + i = 1 + l = k2 + new = 0 + jj = 0 + do 180 it=1,m + if(u(it).lt.t(l) .or. l.gt.nk1) go to 160 + new = 1 + l = l+1 + 160 term = 0. + l0 = l-k2 + do 175 j2=1,idim + fac = 0. + j1 = l0 + do 170 j=1,k1 + j1 = j1+1 + fac = fac+c(j1)*q(it,j) + 170 continue + jj = jj+1 + term = term+(w(it)*(fac-x(jj)))**2 + l0 = l0+n + 175 continue + fpart = fpart+term + if(new.eq.0) go to 180 + store = term*half + fpint(i) = fpart-store + i = i+1 + fpart = store + new = 0 + 180 continue + fpint(nrint) = fpart + do 190 l=1,nplus +c add a new knot. + call fpknot(u,m,t,n,fpint,nrdata,nrint,nest,1) +c if n=nmax we locate the knots as for interpolation + if(n.eq.nmax) go to 10 +c test whether we cannot further increase the number of knots. + if(n.eq.nest) go to 200 + 190 continue +c restart the computations with the new set of knots. + 200 continue +c test whether the least-squares kth degree polynomial curve is a +c solution of our approximation problem. + 250 if(ier.eq.(-2)) go to 440 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline curve sp(u). c +c ********************************************************** c +c we have determined the number of knots and their position. c +c we now compute the b-spline coefficients of the smoothing curve c +c sp(u). the observation matrix a is extended by the rows of matrix c +c b expressing that the kth derivative discontinuities of sp(u) at c +c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c +c ponding weights of these additional rows are set to 1/p. c +c iteratively we then have to determine the value of p such that f(p),c +c the sum of squared residuals be = s. we already know that the least c +c squares kth degree polynomial curve corresponds to p=0, and that c +c the least-squares spline curve corresponds to p=infinity. the c +c iteration process which is proposed here, makes use of rational c +c interpolation. since f(p) is a convex and strictly decreasing c +c function of p, it can be approximated by a rational function c +c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c +c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c +c to calculate the new value of p such that r(p)=s. convergence is c +c guaranteed by taking f1>0 and f3<0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c evaluate the discontinuity jump of the kth derivative of the +c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. + call fpdisc(t,n,k2,b,nest) +c initial value for p. + p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + p = 0. + do 252 i=1,nk1 + p = p+a(i,1) + 252 continue + rn = nk1 + p = rn/p + ich1 = 0 + ich3 = 0 + n8 = n-nmin +c iteration process to find the root of f(p) = s. + do 360 iter=1,maxit +c the rows of matrix b with weight 1/p are rotated into the +c triangularised observation matrix a which is stored in g. + pinv = one/p + do 255 i=1,nc + c(i) = z(i) + 255 continue + do 260 i=1,nk1 + g(i,k2) = 0. + do 260 j=1,k1 + g(i,j) = a(i,j) + 260 continue + do 300 it=1,n8 +c the row of matrix b is rotated into triangle by givens transformation + do 270 i=1,k2 + h(i) = b(it,i)*pinv + 270 continue + do 275 j=1,idim + xi(j) = 0. + 275 continue + do 290 j=it,nk1 + piv = h(1) +c calculate the parameters of the givens transformation. + call fpgivs(piv,g(j,1),cos,sin) +c transformations to right hand side. + j1 = j + do 277 j2=1,idim + call fprota(cos,sin,xi(j2),c(j1)) + j1 = j1+n + 277 continue + if(j.eq.nk1) go to 300 + i2 = k1 + if(j.gt.n8) i2 = nk1-j + do 280 i=1,i2 +c transformations to left hand side. + i1 = i+1 + call fprota(cos,sin,h(i1),g(j,i1)) + h(i) = h(i1) + 280 continue + h(i2+1) = 0. + 290 continue + 300 continue +c backward substitution to obtain the b-spline coefficients. + j1 = 1 + do 305 j2=1,idim + call fpback(g,c(j1),nk1,k2,c(j1),nest) + j1 =j1+n + 305 continue +c computation of f(p). + fp = 0. + l = k2 + jj = 0 + do 330 it=1,m + if(u(it).lt.t(l) .or. l.gt.nk1) go to 310 + l = l+1 + 310 l0 = l-k2 + term = 0. + do 325 j2=1,idim + fac = 0. + j1 = l0 + do 320 j=1,k1 + j1 = j1+1 + fac = fac+c(j1)*q(it,j) + 320 continue + jj = jj+1 + term = term+(fac-x(jj))**2 + l0 = l0+n + 325 continue + fp = fp+term*w(it)**2 + 330 continue +c test whether the approximation sp(u) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c test whether the maximal number of iterations is reached. + if(iter.eq.maxit) go to 400 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 340 + if((f2-f3).gt.acc) go to 335 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p=p1*con9 + p2*con1 + go to 360 + 335 if(f2.lt.0.) ich3=1 + 340 if(ich1.ne.0) go to 350 + if((f1-f2).gt.acc) go to 345 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 360 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 360 + 345 if(f2.gt.0.) ich1=1 +c test whether the iteration process proceeds as theoretically +c expected. + 350 if(f2.ge.f1 .or. f2.le.f3) go to 410 +c find the new value for p. + p = fprati(p1,f1,p2,f2,p3,f3) + 360 continue +c error codes and messages. + 400 ier = 3 + go to 440 + 410 ier = 2 + go to 440 + 420 ier = 1 + go to 440 + 430 ier = -1 + 440 return + end diff --git a/fitpack/fppasu.f b/fitpack/fppasu.f new file mode 100644 index 0000000..fde8687 --- /dev/null +++ b/fitpack/fppasu.f @@ -0,0 +1,393 @@ + subroutine fppasu(iopt,ipar,idim,u,mu,v,mv,z,mz,s,nuest,nvest, + * tol,maxit,nc,nu,tu,nv,tv,c,fp,fp0,fpold,reducu,reducv,fpintu, + * fpintv,lastdi,nplusu,nplusv,nru,nrv,nrdatu,nrdatv,wrk,lwrk,ier) + implicit none +c .. +c ..scalar arguments.. + real*8 s,tol,fp,fp0,fpold,reducu,reducv + integer iopt,idim,mu,mv,mz,nuest,nvest,maxit,nc,nu,nv,lastdi, + * nplusu,nplusv,lwrk,ier +c ..array arguments.. + real*8 u(mu),v(mv),z(mz*idim),tu(nuest),tv(nvest),c(nc*idim), + * fpintu(nuest),fpintv(nvest),wrk(lwrk) + integer ipar(2),nrdatu(nuest),nrdatv(nvest),nru(mu),nrv(mv) +c ..local scalars + real*8 acc,fpms,f1,f2,f3,p,p1,p2,p3,rn,one,con1,con9,con4, + * peru,perv,ub,ue,vb,ve + integer i,ich1,ich3,ifbu,ifbv,ifsu,ifsv,iter,j,lau1,lav1,laa, + * l,lau,lav,lbu,lbv,lq,lri,lsu,lsv,l1,l2,l3,l4,mm,mpm,mvnu,ncof, + * nk1u,nk1v,nmaxu,nmaxv,nminu,nminv,nplu,nplv,npl1,nrintu, + * nrintv,nue,nuk,nve,nuu,nvv +c ..function references.. + real*8 abs,fprati + integer max0,min0 +c ..subroutine references.. +c fpgrpa,fpknot +c .. +c set constants + one = 1 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 +c set boundaries of the approximation domain + ub = u(1) + ue = u(mu) + vb = v(1) + ve = v(mv) +c we partition the working space. + lsu = 1 + lsv = lsu+mu*4 + lri = lsv+mv*4 + mm = max0(nuest,mv) + lq = lri+mm*idim + mvnu = nuest*mv*idim + lau = lq+mvnu + nuk = nuest*5 + lbu = lau+nuk + lav = lbu+nuk + nuk = nvest*5 + lbv = lav+nuk + laa = lbv+nuk + lau1 = lau + if(ipar(1).eq.0) go to 10 + peru = ue-ub + lau1 = laa + laa = laa+4*nuest + 10 lav1 = lav + if(ipar(2).eq.0) go to 20 + perv = ve-vb + lav1 = laa +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(u,v), c +c and the corresponding sum of squared residuals fp=f(p=inf). c +c if iopt=-1 sinf(u,v) 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 s=0 we have spline interpolation; in that case the number of c +c knots equals nmaxu = mu+4+2*ipar(1) and nmaxv = mv+4+2*ipar(2) c +c if s>0 and c +c *iopt=0 we first compute the least-squares polynomial c +c nu=nminu=8 and nv=nminv=8 c +c *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 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c determine the number of knots for polynomial approximation. + 20 nminu = 8 + nminv = 8 + if(iopt.lt.0) go to 100 +c acc denotes the absolute tolerance for the root of f(p)=s. + acc = tol*s +c find nmaxu and nmaxv which denote the number of knots in u- and v- +c direction in case of spline interpolation. + nmaxu = mu+4+2*ipar(1) + nmaxv = mv+4+2*ipar(2) +c find nue and nve which denote the maximum number of knots +c allowed in each direction + nue = min0(nmaxu,nuest) + nve = min0(nmaxv,nvest) + if(s.gt.0.) go to 60 +c if s = 0, s(u,v) is an interpolating spline. + nu = nmaxu + nv = nmaxv +c test whether the required storage space exceeds the available one. + if(nv.gt.nvest .or. nu.gt.nuest) go to 420 +c find the position of the interior knots in case of interpolation. +c the knots in the u-direction. + nuu = nu-8 + if(nuu.eq.0) go to 40 + i = 5 + j = 3-ipar(1) + do 30 l=1,nuu + tu(i) = u(j) + i = i+1 + j = j+1 + 30 continue +c the knots in the v-direction. + 40 nvv = nv-8 + if(nvv.eq.0) go to 60 + i = 5 + j = 3-ipar(2) + do 50 l=1,nvv + tv(i) = v(j) + i = i+1 + j = j+1 + 50 continue + go to 100 +c if s > 0 our initial choice of knots depends on the value of iopt. + 60 if(iopt.eq.0) go to 90 + if(fp0.le.s) go to 90 +c if iopt=1 and fp0 > s we start computing the least- squares spline +c according to the set of knots found at the last call of the routine. +c we determine the number of grid coordinates u(i) inside each knot +c interval (tu(l),tu(l+1)). + l = 5 + j = 1 + nrdatu(1) = 0 + mpm = mu-1 + do 70 i=2,mpm + nrdatu(j) = nrdatu(j)+1 + if(u(i).lt.tu(l)) go to 70 + nrdatu(j) = nrdatu(j)-1 + l = l+1 + j = j+1 + nrdatu(j) = 0 + 70 continue +c we determine the number of grid coordinates v(i) inside each knot +c interval (tv(l),tv(l+1)). + l = 5 + j = 1 + nrdatv(1) = 0 + mpm = mv-1 + do 80 i=2,mpm + nrdatv(j) = nrdatv(j)+1 + if(v(i).lt.tv(l)) go to 80 + nrdatv(j) = nrdatv(j)-1 + l = l+1 + j = j+1 + nrdatv(j) = 0 + 80 continue + go to 100 +c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +c polynomial (which is a spline without interior knots). + 90 nu = nminu + nv = nminv + nrdatu(1) = mu-2 + nrdatv(1) = mv-2 + lastdi = 0 + nplusu = 0 + nplusv = 0 + fp0 = 0. + fpold = 0. + reducu = 0. + reducv = 0. + 100 mpm = mu+mv + ifsu = 0 + ifsv = 0 + ifbu = 0 + ifbv = 0 + p = -one +c main loop for the different sets of knots.mpm=mu+mv is a save upper +c bound for the number of trials. + do 250 iter=1,mpm + if(nu.eq.nminu .and. nv.eq.nminv) ier = -2 +c find nrintu (nrintv) which is the number of knot intervals in the +c u-direction (v-direction). + nrintu = nu-nminu+1 + nrintv = nv-nminv+1 +c find ncof, the number of b-spline coefficients for the current set +c of knots. + nk1u = nu-4 + nk1v = nv-4 + ncof = nk1u*nk1v +c find the position of the additional knots which are needed for the +c b-spline representation of s(u,v). + if(ipar(1).ne.0) go to 110 + i = nu + do 105 j=1,4 + tu(j) = ub + tu(i) = ue + i = i-1 + 105 continue + go to 120 + 110 l1 = 4 + l2 = l1 + l3 = nu-3 + l4 = l3 + tu(l2) = ub + tu(l3) = ue + do 115 j=1,3 + l1 = l1+1 + l2 = l2-1 + l3 = l3+1 + l4 = l4-1 + tu(l2) = tu(l4)-peru + tu(l3) = tu(l1)+peru + 115 continue + 120 if(ipar(2).ne.0) go to 130 + i = nv + do 125 j=1,4 + tv(j) = vb + tv(i) = ve + i = i-1 + 125 continue + go to 140 + 130 l1 = 4 + l2 = l1 + l3 = nv-3 + l4 = l3 + tv(l2) = vb + tv(l3) = ve + do 135 j=1,3 + l1 = l1+1 + l2 = l2-1 + l3 = l3+1 + l4 = l4-1 + tv(l2) = tv(l4)-perv + tv(l3) = tv(l1)+perv + 135 continue +c find the least-squares spline sinf(u,v) and calculate for each knot +c interval tu(j+3)<=u<=tu(j+4) (tv(j+3)<=v<=tv(j+4)) the sum +c of squared residuals fpintu(j),j=1,2,...,nu-7 (fpintv(j),j=1,2,... +c ,nv-7) for the data points having their absciss (ordinate)-value +c belonging to that interval. +c fp gives the total sum of squared residuals. + 140 call fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu,v,mv,z,mz,tu, + * nu,tv,nv,p,c,nc,fp,fpintu,fpintv,mm,mvnu,wrk(lsu),wrk(lsv), + * wrk(lri),wrk(lq),wrk(lau),wrk(lau1),wrk(lav),wrk(lav1), + * wrk(lbu),wrk(lbv),nru,nrv) + if(ier.eq.(-2)) fp0 = fp +c test whether the least-squares spline is an acceptable solution. + if(iopt.lt.0) go to 440 + fpms = fp-s + if(abs(fpms) .lt. acc) go to 440 +c if f(p=inf) < s, we accept the choice of knots. + if(fpms.lt.0.) go to 300 +c if nu=nmaxu and nv=nmaxv, sinf(u,v) is an interpolating spline. + if(nu.eq.nmaxu .and. nv.eq.nmaxv) go to 430 +c increase the number of knots. +c if nu=nue and nv=nve we cannot further increase the number of knots +c because of the storage capacity limitation. + if(nu.eq.nue .and. nv.eq.nve) go to 420 + ier = 0 +c adjust the parameter reducu or reducv according to the direction +c in which the last added knots were located. + if (lastdi.lt.0) go to 150 + if (lastdi.eq.0) go to 170 + go to 160 + 150 reducu = fpold-fp + go to 170 + 160 reducv = fpold-fp +c store the sum of squared residuals for the current set of knots. + 170 fpold = fp +c find nplu, the number of knots we should add in the u-direction. + nplu = 1 + if(nu.eq.nminu) go to 180 + npl1 = nplusu*2 + rn = nplusu + if(reducu.gt.acc) npl1 = rn*fpms/reducu + nplu = min0(nplusu*2,max0(npl1,nplusu/2,1)) +c find nplv, the number of knots we should add in the v-direction. + 180 nplv = 1 + if(nv.eq.nminv) go to 190 + npl1 = nplusv*2 + rn = nplusv + if(reducv.gt.acc) npl1 = rn*fpms/reducv + nplv = min0(nplusv*2,max0(npl1,nplusv/2,1)) + 190 if (nplu.lt.nplv) go to 210 + if (nplu.eq.nplv) go to 200 + go to 230 + 200 if(lastdi.lt.0) go to 230 + 210 if(nu.eq.nue) go to 230 +c addition in the u-direction. + lastdi = -1 + nplusu = nplu + ifsu = 0 + do 220 l=1,nplusu +c add a new knot in the u-direction + call fpknot(u,mu,tu,nu,fpintu,nrdatu,nrintu,nuest,1) +c test whether we cannot further increase the number of knots in the +c u-direction. + if(nu.eq.nue) go to 250 + 220 continue + go to 250 + 230 if(nv.eq.nve) go to 210 +c addition in the v-direction. + lastdi = 1 + nplusv = nplv + ifsv = 0 + do 240 l=1,nplusv +c add a new knot in the v-direction. + call fpknot(v,mv,tv,nv,fpintv,nrdatv,nrintv,nvest,1) +c test whether we cannot further increase the number of knots in the +c v-direction. + if(nv.eq.nve) go to 250 + 240 continue +c restart the computations with the new set of knots. + 250 continue +c test whether the least-squares polynomial is a solution of our +c approximation problem. + 300 if(ier.eq.(-2)) go to 440 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline sp(u,v) c +c ***************************************************** c +c we have determined the number of knots and their position. we now c +c compute the b-spline coefficients of the smoothing spline sp(u,v). c +c this smoothing spline varies with the parameter p in such a way thatc +c f(p)=suml=1,idim(sumi=1,mu(sumj=1,mv((z(i,j,l)-sp(u(i),v(j),l))**2) c +c is a continuous, strictly decreasing function of p. moreover the c +c least-squares polynomial corresponds to p=0 and the least-squares c +c spline to p=infinity. iteratively we then have to determine the c +c positive value of p such that f(p)=s. the process which is proposed c +c here makes use of rational interpolation. f(p) is approximated by a c +c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c +c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c +c are used to calculate the new value of p such that r(p)=s. c +c convergence is guaranteed by taking f1 > 0 and f3 < 0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c initial value for p. + p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + p = one + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p)=s. + do 350 iter = 1,maxit +c find the smoothing spline sp(u,v) and the corresponding sum of +c squared residuals fp. + call fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu,v,mv,z,mz,tu, + * nu,tv,nv,p,c,nc,fp,fpintu,fpintv,mm,mvnu,wrk(lsu),wrk(lsv), + * wrk(lri),wrk(lq),wrk(lau),wrk(lau1),wrk(lav),wrk(lav1), + * wrk(lbu),wrk(lbv),nru,nrv) +c test whether the approximation sp(u,v) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c test whether the maximum allowable number of iterations has been +c reached. + if(iter.eq.maxit) go to 400 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 320 + if((f2-f3).gt.acc) go to 310 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 + p2*con1 + go to 350 + 310 if(f2.lt.0.) ich3 = 1 + 320 if(ich1.ne.0) go to 340 + if((f1-f2).gt.acc) go to 330 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 350 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 350 +c test whether the iteration process proceeds as theoretically +c expected. + 330 if(f2.gt.0.) ich1 = 1 + 340 if(f2.ge.f1 .or. f2.le.f3) go to 410 +c find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 350 continue +c error codes and messages. + 400 ier = 3 + go to 440 + 410 ier = 2 + go to 440 + 420 ier = 1 + go to 440 + 430 ier = -1 + fp = 0. + 440 return + end diff --git a/fitpack/fpperi.f b/fitpack/fpperi.f new file mode 100644 index 0000000..c461dba --- /dev/null +++ b/fitpack/fpperi.f @@ -0,0 +1,617 @@ + recursive subroutine fpperi(iopt,x,y,w,m,k,s,nest,tol,maxit, + * k1,k2,n,t,c,fp,fpint,z,a1,a2,b,g1,g2,q,nrdata,ier) + implicit none +c .. +c ..scalar arguments.. + real*8 s,tol,fp + integer iopt,m,k,nest,maxit,k1,k2,n,ier +c ..array arguments.. + real*8 x(m),y(m),w(m),t(nest),c(nest),fpint(nest),z(nest), + * a1(nest,k1),a2(nest,k),b(nest,k2),g1(nest,k2),g2(nest,k1), + * q(m,k1) + integer nrdata(nest) +c ..local scalars.. + real*8 acc,cos,c1,d1,fpart,fpms,fpold,fp0,f1,f2,f3,p,per,pinv,piv, + * + * p1,p2,p3,sin,store,term,wi,xi,yi,rn,one,con1,con4,con9,half + integer i,ich1,ich3,ij,ik,it,iter,i1,i2,i3,j,jk,jper,j1,j2,kk, + * kk1,k3,l,l0,l1,l5,mm,m1,new,nk1,nk2,nmax,nmin,nplus,npl1, + * nrint,n10,n11,n7,n8 +c ..local arrays.. + real*8 h(6),h1(7),h2(6) +c ..function references.. + real*8 abs,fprati + integer max0,min0 +c ..subroutine references.. +c fpbacp,fpbspl,fpgivs,fpdisc,fpknot,fprota +c .. +c set constants + one = 0.1e+01 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 + half = 0.5e0 +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 periodic spline c +c sinf(x). if the sum f(p=inf) <= s we accept the choice of knots. c +c the initial choice of knots depends on the value of s and iopt. c +c if s=0 we have spline interpolation; in that case the number of c +c knots equals nmax = m+2*k. c +c if s > 0 and c +c iopt=0 we first compute the least-squares polynomial of c +c degree k; n = nmin = 2*k+2. since s(x) must be periodic we c +c find that s(x) is a constant function. c +c iopt=1 we start with the set of knots found at the last c +c call of the routine, except for the case that s > fp0; then c +c we compute directly the least-squares periodic polynomial. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + m1 = m-1 + kk = k + kk1 = k1 + k3 = 3*k+1 + nmin = 2*k1 +c determine the length of the period of s(x). + per = x(m)-x(1) + if(iopt.lt.0) go to 50 +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s +c determine nmax, the number of knots for periodic spline interpolation + nmax = m+2*k + if(s.gt.0. .or. nmax.eq.nmin) go to 30 +c if s=0, s(x) is an interpolating spline. + n = nmax +c test whether the required storage space exceeds the available one. + if(n.gt.nest) go to 620 +c find the position of the interior knots in case of interpolation. + 5 if((k/2)*2 .eq. k) go to 20 + do 10 i=2,m1 + j = i+k + t(j) = x(i) + 10 continue + if(s.gt.0.) go to 50 + kk = k-1 + kk1 = k + if(kk.gt.0) go to 50 + t(1) = t(m)-per + t(2) = x(1) + t(m+1) = x(m) + t(m+2) = t(3)+per + do 15 i=1,m1 + c(i) = y(i) + 15 continue + c(m) = c(1) + fp = 0. + fpint(n) = fp0 + fpint(n-1) = 0. + nrdata(n) = 0 + go to 630 + 20 do 25 i=2,m1 + j = i+k + t(j) = (x(i)+x(i-1))*half + 25 continue + go to 50 +c if s > 0 our initial choice depends on the value of iopt. +c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +c periodic polynomial. (i.e. a constant function). +c if iopt=1 and fp0>s we start computing the least-squares periodic +c spline according the set of knots found at the last call of the +c routine. + 30 if(iopt.eq.0) go to 35 + if(n.eq.nmin) go to 35 + fp0 = fpint(n) + fpold = fpint(n-1) + nplus = nrdata(n) + if(fp0.gt.s) go to 50 +c the case that s(x) is a constant function is treated separetely. +c find the least-squares constant c1 and compute fp0 at the same time. + 35 fp0 = 0. + d1 = 0. + c1 = 0. + do 40 it=1,m1 + wi = w(it) + yi = y(it)*wi + call fpgivs(wi,d1,cos,sin) + call fprota(cos,sin,yi,c1) + fp0 = fp0+yi**2 + 40 continue + c1 = c1/d1 +c test whether that constant function is a solution of our problem. + fpms = fp0-s + if(fpms.lt.acc .or. nmax.eq.nmin) go to 640 + fpold = fp0 +c test whether the required storage space exceeds the available one. + if(nmin.ge.nest) go to 620 +c start computing the least-squares periodic spline with one +c interior knot. + nplus = 1 + n = nmin+1 + mm = (m+1)/2 + t(k2) = x(mm) + nrdata(1) = mm-2 + nrdata(2) = m1-mm +c main loop for the different sets of knots. m is a save upper +c bound for the number of trials. + 50 do 340 iter=1,m +c find nrint, the number of knot intervals. + nrint = n-nmin+1 +c find the position of the additional knots which are needed for +c the b-spline representation of s(x). if we take +c t(k+1) = x(1), t(n-k) = x(m) +c t(k+1-j) = t(n-k-j) - per, j=1,2,...k +c t(n-k+j) = t(k+1+j) + per, j=1,2,...k +c then s(x) is a periodic spline with period per if the b-spline +c coefficients satisfy the following conditions +c c(n7+j) = c(j), j=1,...k (**) with n7=n-2*k-1. + t(k1) = x(1) + nk1 = n-k1 + nk2 = nk1+1 + t(nk2) = x(m) + do 60 j=1,k + i1 = nk2+j + i2 = nk2-j + j1 = k1+j + j2 = k1-j + t(i1) = t(j1)+per + t(j2) = t(i2)-per + 60 continue +c compute the b-spline coefficients c(j),j=1,...n7 of the least-squares +c periodic spline sinf(x). the observation matrix a is built up row +c by row while taking into account condition (**) and is reduced to +c triangular form by givens transformations . +c at the same time fp=f(p=inf) is computed. +c the n7 x n7 triangularised upper matrix a has the form +c ! a1 ' ! +c a = ! ' a2 ! +c ! 0 ' ! +c with a2 a n7 x k matrix and a1 a n10 x n10 upper triangular +c matrix of bandwidth k+1 ( n10 = n7-k). +c initialization. + do 70 i=1,nk1 + z(i) = 0. + do 70 j=1,kk1 + a1(i,j) = 0. + 70 continue + n7 = nk1-k + n10 = n7-kk + jper = 0 + fp = 0. + l = k1 + do 290 it=1,m1 +c fetch the current data point x(it),y(it) + xi = x(it) + wi = w(it) + yi = y(it)*wi +c search for knot interval t(l) <= xi < t(l+1). + 80 if(xi.lt.t(l+1)) go to 85 + l = l+1 + go to 80 +c evaluate the (k+1) non-zero b-splines at xi and store them in q. + 85 call fpbspl(t,n,k,xi,l,h) + do 90 i=1,k1 + q(it,i) = h(i) + h(i) = h(i)*wi + 90 continue + l5 = l-k1 +c test whether the b-splines nj,k+1(x),j=1+n7,...nk1 are all zero at xi + if(l5.lt.n10) go to 285 + if(jper.ne.0) go to 160 +c initialize the matrix a2. + do 95 i=1,n7 + do 95 j=1,kk + a2(i,j) = 0. + 95 continue + jk = n10+1 + do 110 i=1,kk + ik = jk + do 100 j=1,kk1 + if(ik.le.0) go to 105 + a2(ik,i) = a1(ik,j) + ik = ik-1 + 100 continue + 105 jk = jk+1 + 110 continue + jper = 1 +c if one of the b-splines nj,k+1(x),j=n7+1,...nk1 is not zero at xi +c we take account of condition (**) for setting up the new row +c of the observation matrix a. this row is stored in the arrays h1 +c (the part with respect to a1) and h2 (the part with +c respect to a2). + 160 do 170 i=1,kk + h1(i) = 0. + h2(i) = 0. + 170 continue + h1(kk1) = 0. + j = l5-n10 + do 210 i=1,kk1 + j = j+1 + l0 = j + 180 l1 = l0-kk + if(l1.le.0) go to 200 + if(l1.le.n10) go to 190 + l0 = l1-n10 + go to 180 + 190 h1(l1) = h(i) + go to 210 + 200 h2(l0) = h2(l0)+h(i) + 210 continue +c rotate the new row of the observation matrix into triangle +c by givens transformations. + if(n10.le.0) go to 250 +c rotation with the rows 1,2,...n10 of matrix a. + do 240 j=1,n10 + piv = h1(1) + if(piv.ne.0.) go to 214 + do 212 i=1,kk + h1(i) = h1(i+1) + 212 continue + h1(kk1) = 0. + go to 240 +c calculate the parameters of the givens transformation. + 214 call fpgivs(piv,a1(j,1),cos,sin) +c transformation to the right hand side. + call fprota(cos,sin,yi,z(j)) +c transformations to the left hand side with respect to a2. + do 220 i=1,kk + call fprota(cos,sin,h2(i),a2(j,i)) + 220 continue + if(j.eq.n10) go to 250 + i2 = min0(n10-j,kk) +c transformations to the left hand side with respect to a1. + do 230 i=1,i2 + i1 = i+1 + call fprota(cos,sin,h1(i1),a1(j,i1)) + h1(i) = h1(i1) + 230 continue + h1(i1) = 0. + 240 continue +c rotation with the rows n10+1,...n7 of matrix a. + 250 do 270 j=1,kk + ij = n10+j + if(ij.le.0) go to 270 + piv = h2(j) + if(piv.eq.0.) go to 270 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a2(ij,j),cos,sin) +c transformations to right hand side. + call fprota(cos,sin,yi,z(ij)) + if(j.eq.kk) go to 280 + j1 = j+1 +c transformations to left hand side. + do 260 i=j1,kk + call fprota(cos,sin,h2(i),a2(ij,i)) + 260 continue + 270 continue +c add contribution of this row to the sum of squares of residual +c right hand sides. + 280 fp = fp+yi**2 + go to 290 +c rotation of the new row of the observation matrix into +c triangle in case the b-splines nj,k+1(x),j=n7+1,...n-k-1 are all zero +c at xi. + 285 j = l5 + do 140 i=1,kk1 + j = j+1 + piv = h(i) + if(piv.eq.0.) go to 140 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a1(j,1),cos,sin) +c transformations to right hand side. + call fprota(cos,sin,yi,z(j)) + if(i.eq.kk1) go to 150 + i2 = 1 + i3 = i+1 +c transformations to left hand side. + do 130 i1=i3,kk1 + i2 = i2+1 + call fprota(cos,sin,h(i1),a1(j,i2)) + 130 continue + 140 continue +c add contribution of this row to the sum of squares of residual +c right hand sides. + 150 fp = fp+yi**2 + 290 continue + fpint(n) = fp0 + fpint(n-1) = fpold + nrdata(n) = nplus +c backward substitution to obtain the b-spline coefficients c(j),j=1,.n + call fpbacp(a1,a2,z,n7,kk,c,kk1,nest) +c calculate from condition (**) the coefficients c(j+n7),j=1,2,...k. + do 295 i=1,k + j = i+n7 + c(j) = c(i) + 295 continue + if(iopt.lt.0) go to 660 +c test whether the approximation sinf(x) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 660 +c if f(p=inf) < s accept the choice of knots. + if(fpms.lt.0.) go to 350 +c if n=nmax, sinf(x) is an interpolating spline. + if(n.eq.nmax) go to 630 +c increase the number of knots. +c if n=nest we cannot increase the number of knots because of the +c storage capacity limitation. + if(n.eq.nest) go to 620 +c determine the number of knots nplus we are going to add. + npl1 = nplus*2 + rn = nplus + if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) + nplus = min0(nplus*2,max0(npl1,nplus/2,1)) + fpold = fp +c compute the sum(wi*(yi-s(xi))**2) for each knot interval +c t(j+k) <= xi <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. + fpart = 0. + i = 1 + l = k1 + do 320 it=1,m1 + if(x(it).lt.t(l)) go to 300 + new = 1 + l = l+1 + 300 term = 0. + l0 = l-k2 + do 310 j=1,k1 + l0 = l0+1 + term = term+c(l0)*q(it,j) + 310 continue + term = (w(it)*(term-y(it)))**2 + fpart = fpart+term + if(new.eq.0) go to 320 + if(l.gt.k2) go to 315 + fpint(nrint) = term + new = 0 + go to 320 + 315 store = term*half + fpint(i) = fpart-store + i = i+1 + fpart = store + new = 0 + 320 continue + fpint(nrint) = fpint(nrint)+fpart + do 330 l=1,nplus +c add a new knot + call fpknot(x,m,t,n,fpint,nrdata,nrint,nest,1) +c if n=nmax we locate the knots as for interpolation. + if(n.eq.nmax) go to 5 +c test whether we cannot further increase the number of knots. + if(n.eq.nest) go to 340 + 330 continue +c restart the computations with the new set of knots. + 340 continue +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing periodic spline sp(x). c +c ************************************************************* c +c we have determined the number of knots and their position. c +c we now compute the b-spline coefficients of the smoothing spline c +c sp(x). the observation matrix a is extended by the rows of matrix c +c b expressing that the kth derivative discontinuities of sp(x) at c +c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c +c ponding weights of these additional rows are set to 1/sqrt(p). c +c iteratively we then have to determine the value of p such that c +c f(p)=sum(w(i)*(y(i)-sp(x(i)))**2) be = s. we already know that c +c the least-squares constant function corresponds to p=0, and that c +c the least-squares periodic spline corresponds to p=infinity. the c +c iteration process which is proposed here, makes use of rational c +c interpolation. since f(p) is a convex and strictly decreasing c +c function of p, it can be approximated by a rational function c +c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c +c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c +c to calculate the new value of p such that r(p)=s. convergence is c +c guaranteed by taking f1>0 and f3<0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c evaluate the discontinuity jump of the kth derivative of the +c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. + 350 call fpdisc(t,n,k2,b,nest) +c initial value for p. + p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + n11 = n10-1 + n8 = n7-1 + p = 0. + l = n7 + do 352 i=1,k + j = k+1-i + p = p+a2(l,j) + l = l-1 + if(l.eq.0) go to 356 + 352 continue + do 354 i=1,n10 + p = p+a1(i,1) + 354 continue + 356 rn = n7 + p = rn/p + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p) = s. + do 595 iter=1,maxit +c form the matrix g as the matrix a extended by the rows of matrix b. +c the rows of matrix b with weight 1/p are rotated into +c the triangularised observation matrix a. +c after triangularisation our n7 x n7 matrix g takes the form +c ! g1 ' ! +c g = ! ' g2 ! +c ! 0 ' ! +c with g2 a n7 x (k+1) matrix and g1 a n11 x n11 upper triangular +c matrix of bandwidth k+2. ( n11 = n7-k-1) + pinv = one/p +c store matrix a into g + do 360 i=1,n7 + c(i) = z(i) + g1(i,k1) = a1(i,k1) + g1(i,k2) = 0. + g2(i,1) = 0. + do 360 j=1,k + g1(i,j) = a1(i,j) + g2(i,j+1) = a2(i,j) + 360 continue + l = n10 + do 370 j=1,k1 + if(l.le.0) go to 375 + g2(l,1) = a1(l,j) + l = l-1 + 370 continue + 375 do 540 it=1,n8 +c fetch a new row of matrix b and store it in the arrays h1 (the part +c with respect to g1) and h2 (the part with respect to g2). + yi = 0. + do 380 i=1,k1 + h1(i) = 0. + h2(i) = 0. + 380 continue + h1(k2) = 0. + if(it.gt.n11) go to 420 + l = it + l0 = it + do 390 j=1,k2 + if(l0.eq.n10) go to 400 + h1(j) = b(it,j)*pinv + l0 = l0+1 + 390 continue + go to 470 + 400 l0 = 1 + do 410 l1=j,k2 + h2(l0) = b(it,l1)*pinv + l0 = l0+1 + 410 continue + go to 470 + 420 l = 1 + i = it-n10 + do 460 j=1,k2 + i = i+1 + l0 = i + 430 l1 = l0-k1 + if(l1.le.0) go to 450 + if(l1.le.n11) go to 440 + l0 = l1-n11 + go to 430 + 440 h1(l1) = b(it,j)*pinv + go to 460 + 450 h2(l0) = h2(l0)+b(it,j)*pinv + 460 continue + if(n11.le.0) go to 510 +c rotate this row into triangle by givens transformations without +c square roots. +c rotation with the rows l,l+1,...n11. + 470 do 500 j=l,n11 + piv = h1(1) +c calculate the parameters of the givens transformation. + call fpgivs(piv,g1(j,1),cos,sin) +c transformation to right hand side. + call fprota(cos,sin,yi,c(j)) +c transformation to the left hand side with respect to g2. + do 480 i=1,k1 + call fprota(cos,sin,h2(i),g2(j,i)) + 480 continue + if(j.eq.n11) go to 510 + i2 = min0(n11-j,k1) +c transformation to the left hand side with respect to g1. + do 490 i=1,i2 + i1 = i+1 + call fprota(cos,sin,h1(i1),g1(j,i1)) + h1(i) = h1(i1) + 490 continue + h1(i1) = 0. + 500 continue +c rotation with the rows n11+1,...n7 + 510 do 530 j=1,k1 + ij = n11+j + if(ij.le.0) go to 530 + piv = h2(j) +c calculate the parameters of the givens transformation + call fpgivs(piv,g2(ij,j),cos,sin) +c transformation to the right hand side. + call fprota(cos,sin,yi,c(ij)) + if(j.eq.k1) go to 540 + j1 = j+1 +c transformation to the left hand side. + do 520 i=j1,k1 + call fprota(cos,sin,h2(i),g2(ij,i)) + 520 continue + 530 continue + 540 continue +c backward substitution to obtain the b-spline coefficients +c c(j),j=1,2,...n7 of sp(x). + call fpbacp(g1,g2,c,n7,k1,c,k2,nest) +c calculate from condition (**) the b-spline coefficients c(n7+j),j=1,. + do 545 i=1,k + j = i+n7 + c(j) = c(i) + 545 continue +c computation of f(p). + fp = 0. + l = k1 + do 570 it=1,m1 + if(x(it).lt.t(l)) go to 550 + l = l+1 + 550 l0 = l-k2 + term = 0. + do 560 j=1,k1 + l0 = l0+1 + term = term+c(l0)*q(it,j) + 560 continue + fp = fp+(w(it)*(term-y(it)))**2 + 570 continue +c test whether the approximation sp(x) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 660 +c test whether the maximal number of iterations is reached. + if(iter.eq.maxit) go to 600 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 580 + if((f2-f3) .gt. acc) go to 575 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 +p2*con1 + go to 595 + 575 if(f2.lt.0.) ich3 = 1 + 580 if(ich1.ne.0) go to 590 + if((f1-f2) .gt. acc) go to 585 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 595 + if(p.ge.p3) p = p2*con1 +p3*con9 + go to 595 + 585 if(f2.gt.0.) ich1 = 1 +c test whether the iteration process proceeds as theoretically +c expected. + 590 if(f2.ge.f1 .or. f2.le.f3) go to 610 +c find the new value for p. + p = fprati(p1,f1,p2,f2,p3,f3) + 595 continue +c error codes and messages. + 600 ier = 3 + go to 660 + 610 ier = 2 + go to 660 + 620 ier = 1 + go to 660 + 630 ier = -1 + go to 660 + 640 ier = -2 +c the least-squares constant function c1 is a solution of our problem. +c a constant function is a spline of degree k with all b-spline +c coefficients equal to that constant c1. + do 650 i=1,k1 + rn = k1-i + t(i) = x(1)-rn*per + c(i) = c1 + j = i+k1 + rn = i-1 + t(j) = x(m)+rn*per + 650 continue + n = nmin + fp = fp0 + fpint(n) = fp0 + fpint(n-1) = 0. + nrdata(n) = 0 + 660 return + end diff --git a/fitpack/fppocu.f b/fitpack/fppocu.f new file mode 100644 index 0000000..25af847 --- /dev/null +++ b/fitpack/fppocu.f @@ -0,0 +1,73 @@ + recursive subroutine fppocu(idim,k,a,b,ib,db,nb,ie,de,ne,cp,np) + implicit none +c subroutine fppocu finds a idim-dimensional polynomial curve p(u) = +c (p1(u),p2(u),...,pidim(u)) of degree k, satisfying certain derivative +c constraints at the end points a and b, i.e. +c (l) +c if ib > 0 : pj (a) = db(idim*l+j), l=0,1,...,ib-1 +c (l) +c if ie > 0 : pj (b) = de(idim*l+j), l=0,1,...,ie-1 +c +c the polynomial curve is returned in its b-spline representation +c ( coefficients cp(j), j=1,2,...,np ) +c .. +c ..scalar arguments.. + integer idim,k,ib,nb,ie,ne,np + real*8 a,b +c ..array arguments.. + real*8 db(nb),de(ne),cp(np) +c ..local scalars.. + real*8 ab,aki + integer i,id,j,jj,l,ll,k1,k2 +c ..local array.. + real*8 work(6,6) +c .. + k1 = k+1 + k2 = 2*k1 + ab = b-a + do 110 id=1,idim + do 10 j=1,k1 + work(j,1) = 0. + 10 continue + if(ib.eq.0) go to 50 + l = id + do 20 i=1,ib + work(1,i) = db(l) + l = l+idim + 20 continue + if(ib.eq.1) go to 50 + ll = ib + do 40 j=2,ib + ll = ll-1 + do 30 i=1,ll + aki = k1-i + work(j,i) = ab*work(j-1,i+1)/aki + work(j-1,i) + 30 continue + 40 continue + 50 if(ie.eq.0) go to 90 + l = id + j = k1 + do 60 i=1,ie + work(j,i) = de(l) + l = l+idim + j = j-1 + 60 continue + if(ie.eq.1) go to 90 + ll = ie + do 80 jj=2,ie + ll = ll-1 + j = k1+1-jj + do 70 i=1,ll + aki = k1-i + work(j,i) = work(j+1,i) - ab*work(j,i+1)/aki + j = j-1 + 70 continue + 80 continue + 90 l = (id-1)*k2 + do 100 j=1,k1 + l = l+1 + cp(l) = work(j,1) + 100 continue + 110 continue + return + end diff --git a/fitpack/fppogr.f b/fitpack/fppogr.f new file mode 100644 index 0000000..a80bd6e --- /dev/null +++ b/fitpack/fppogr.f @@ -0,0 +1,411 @@ + recursive subroutine fppogr(iopt,ider,u,mu,v,mv,z,mz,z0,r,s, + * nuest,nvest,tol,maxit,nc,nu,tu,nv,tv,c,fp,fp0,fpold,reducu, + * reducv,fpintu,fpintv,dz,step,lastdi,nplusu,nplusv,lasttu,nru, + * nrv,nrdatu,nrdatv,wrk,lwrk,ier) + implicit none +c .. +c ..scalar arguments.. + integer mu,mv,mz,nuest,nvest,maxit,nc,nu,nv,lastdi,nplusu,nplusv, + * lasttu,lwrk,ier + real*8 z0,r,s,tol,fp,fp0,fpold,reducu,reducv,step +c ..array arguments.. + integer iopt(3),ider(2),nrdatu(nuest),nrdatv(nvest),nru(mu), + * nrv(mv) + real*8 u(mu),v(mv),z(mz),tu(nuest),tv(nvest),c(nc),fpintu(nuest), + * fpintv(nvest),dz(3),wrk(lwrk) +c ..local scalars.. + real*8 acc,fpms,f1,f2,f3,p,per,pi,p1,p2,p3,vb,ve,zmax,zmin,rn,one, + * + * con1,con4,con9 + integer i,ich1,ich3,ifbu,ifbv,ifsu,ifsv,istart,iter,i1,i2,j,ju, + * ktu,l,l1,l2,l3,l4,mpm,mumin,mu0,mu1,nn,nplu,nplv,npl1,nrintu, + * nrintv,nue,numax,nve,nvmax +c ..local arrays.. + integer idd(2) + real*8 dzz(3) +c ..function references.. + real*8 abs,datan2,fprati + integer max0,min0 +c ..subroutine references.. +c fpknot,fpopdi +c .. +c set constants + one = 1d0 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 +c initialization + ifsu = 0 + ifsv = 0 + ifbu = 0 + ifbv = 0 + p = -one + mumin = 4-iopt(3) + if(ider(1).ge.0) mumin = mumin-1 + if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1 + pi = datan2(0d0,-one) + per = pi+pi + vb = v(1) + ve = vb+per +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(u,v) c +c and the corresponding sum of squared residuals fp = f(p=inf). c +c if iopt(1)=-1 sinf(u,v) is the requested approximation. c +c if iopt(1)>=0 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 s=0 we have spline interpolation; in that case the number of c +c knots in the u-direction equals nu=numax=mu+5+iopt(2)+iopt(3) c +c and in the v-direction nv=nvmax=mv+7. c +c if s>0 and c +c iopt(1)=0 we first compute the least-squares polynomial,i.e. a c +c spline without interior knots : nu=8 ; nv=8. c +c iopt(1)=1 we start with the set of knots found at the last call c +c of the routine, except for the case that s > fp0; then we c +c compute the least-squares polynomial directly. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + if(iopt(1).lt.0) go to 120 +c acc denotes the absolute tolerance for the root of f(p)=s. + acc = tol*s +c numax and nvmax denote the number of knots needed for interpolation. + numax = mu+5+iopt(2)+iopt(3) + nvmax = mv+7 + nue = min0(numax,nuest) + nve = min0(nvmax,nvest) + if(s.gt.0.) go to 100 +c if s = 0, s(u,v) is an interpolating spline. + nu = numax + nv = nvmax +c test whether the required storage space exceeds the available one. + if(nu.gt.nuest .or. nv.gt.nvest) go to 420 +c find the position of the knots in the v-direction. + do 10 l=1,mv + tv(l+3) = v(l) + 10 continue + tv(mv+4) = ve + l1 = mv-2 + l2 = mv+5 + do 20 i=1,3 + tv(i) = v(l1)-per + tv(l2) = v(i+1)+per + l1 = l1+1 + l2 = l2+1 + 20 continue +c if not all the derivative values g(i,j) are given, we will first +c estimate these values by computing a least-squares spline + idd(1) = ider(1) + if(idd(1).eq.0) idd(1) = 1 + if(idd(1).gt.0) dz(1) = z0 + idd(2) = ider(2) + if(ider(1).lt.0) go to 30 + if(iopt(2).eq.0 .or. ider(2).ne.0) go to 70 +c we set up the knots in the u-direction for computing the least-squares +c spline. + 30 i1 = 3 + i2 = mu-2 + nu = 4 + do 40 i=1,mu + if(i1.gt.i2) go to 50 + nu = nu+1 + tu(nu) = u(i1) + i1 = i1+2 + 40 continue + 50 do 60 i=1,4 + tu(i) = 0. + nu = nu+1 + tu(nu) = r + 60 continue +c we compute the least-squares spline for estimating the derivatives. + call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,iopt,idd, + * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, + * wrk,lwrk) + ifsu = 0 +c if all the derivatives at the origin are known, we compute the +c interpolating spline. +c we set up the knots in the u-direction, needed for interpolation. + 70 nn = numax-8 + if(nn.eq.0) go to 95 + ju = 2-iopt(2) + do 80 l=1,nn + tu(l+4) = u(ju) + ju = ju+1 + 80 continue + nu = numax + l = nu + do 90 i=1,4 + tu(i) = 0. + tu(l) = r + l = l-1 + 90 continue +c we compute the interpolating spline. + 95 call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,iopt,idd, + * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, + * wrk,lwrk) + go to 430 +c if s>0 our initial choice of knots depends on the value of iopt(1). + 100 ier = 0 + if(iopt(1).eq.0) go to 115 + step = -step + if(fp0.le.s) go to 115 +c if iopt(1)=1 and fp0 > s we start computing the least-squares spline +c according to the set of knots found at the last call of the routine. +c we determine the number of grid coordinates u(i) inside each knot +c interval (tu(l),tu(l+1)). + l = 5 + j = 1 + nrdatu(1) = 0 + mu0 = 2-iopt(2) + mu1 = mu-2+iopt(3) + do 105 i=mu0,mu1 + nrdatu(j) = nrdatu(j)+1 + if(u(i).lt.tu(l)) go to 105 + nrdatu(j) = nrdatu(j)-1 + l = l+1 + j = j+1 + nrdatu(j) = 0 + 105 continue +c we determine the number of grid coordinates v(i) inside each knot +c interval (tv(l),tv(l+1)). + l = 5 + j = 1 + nrdatv(1) = 0 + do 110 i=2,mv + nrdatv(j) = nrdatv(j)+1 + if(v(i).lt.tv(l)) go to 110 + nrdatv(j) = nrdatv(j)-1 + l = l+1 + j = j+1 + nrdatv(j) = 0 + 110 continue + idd(1) = ider(1) + idd(2) = ider(2) + go to 120 +c if iopt(1)=0 or iopt(1)=1 and s >= fp0,we start computing the least- +c squares polynomial (which is a spline without interior knots). + 115 ier = -2 + idd(1) = ider(1) + idd(2) = 1 + nu = 8 + nv = 8 + nrdatu(1) = mu-3+iopt(2)+iopt(3) + nrdatv(1) = mv-1 + lastdi = 0 + nplusu = 0 + nplusv = 0 + fp0 = 0. + fpold = 0. + reducu = 0. + reducv = 0. +c main loop for the different sets of knots.mpm=mu+mv is a save upper +c bound for the number of trials. + 120 mpm = mu+mv + do 270 iter=1,mpm +c find nrintu (nrintv) which is the number of knot intervals in the +c u-direction (v-direction). + nrintu = nu-7 + nrintv = nv-7 +c find the position of the additional knots which are needed for the +c b-spline representation of s(u,v). + i = nu + do 130 j=1,4 + tu(j) = 0. + tu(i) = r + i = i-1 + 130 continue + l1 = 4 + l2 = l1 + l3 = nv-3 + l4 = l3 + tv(l2) = vb + tv(l3) = ve + do 140 j=1,3 + l1 = l1+1 + l2 = l2-1 + l3 = l3+1 + l4 = l4-1 + tv(l2) = tv(l4)-per + tv(l3) = tv(l1)+per + 140 continue +c find an estimate of the range of possible values for the optimal +c derivatives at the origin. + ktu = nrdatu(1)+2-iopt(2) + if(nrintu.eq.1) ktu = mu + if(ktu.lt.mumin) ktu = mumin + if(ktu.eq.lasttu) go to 150 + zmin = z0 + zmax = z0 + l = mv*ktu + do 145 i=1,l + if(z(i).lt.zmin) zmin = z(i) + if(z(i).gt.zmax) zmax = z(i) + 145 continue + step = zmax-zmin + lasttu = ktu +c find the least-squares spline sinf(u,v). + 150 call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,iopt,idd, + * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, + * wrk,lwrk) + if(step.lt.0.) step = -step + if(ier.eq.(-2)) fp0 = fp +c test whether the least-squares spline is an acceptable solution. + if(iopt(1).lt.0) go to 440 + fpms = fp-s + if(abs(fpms) .lt. acc) go to 440 +c if f(p=inf) < s, we accept the choice of knots. + if(fpms.lt.0.) go to 300 +c if nu=numax and nv=nvmax, sinf(u,v) is an interpolating spline + if(nu.eq.numax .and. nv.eq.nvmax) go to 430 +c increase the number of knots. +c if nu=nue and nv=nve we cannot further increase the number of knots +c because of the storage capacity limitation. + if(nu.eq.nue .and. nv.eq.nve) go to 420 + if(ider(1).eq.0) fpintu(1) = fpintu(1)+(z0-c(1))**2 + ier = 0 +c adjust the parameter reducu or reducv according to the direction +c in which the last added knots were located. + if (lastdi.lt.0) go to 160 + if (lastdi.eq.0) go to 155 + go to 170 + 155 nplv = 3 + idd(2) = ider(2) + fpold = fp + go to 230 + 160 reducu = fpold-fp + go to 175 + 170 reducv = fpold-fp +c store the sum of squared residuals for the current set of knots. + 175 fpold = fp +c find nplu, the number of knots we should add in the u-direction. + nplu = 1 + if(nu.eq.8) go to 180 + npl1 = nplusu*2 + rn = nplusu + if(reducu.gt.acc) npl1 = rn*fpms/reducu + nplu = min0(nplusu*2,max0(npl1,nplusu/2,1)) +c find nplv, the number of knots we should add in the v-direction. + 180 nplv = 3 + if(nv.eq.8) go to 190 + npl1 = nplusv*2 + rn = nplusv + if(reducv.gt.acc) npl1 = rn*fpms/reducv + nplv = min0(nplusv*2,max0(npl1,nplusv/2,1)) +c test whether we are going to add knots in the u- or v-direction. + 190 if (nplu.lt.nplv) go to 210 + if (nplu.eq.nplv) go to 200 + go to 230 + 200 if(lastdi.lt.0) go to 230 + 210 if(nu.eq.nue) go to 230 +c addition in the u-direction. + lastdi = -1 + nplusu = nplu + ifsu = 0 + istart = 0 + if(iopt(2).eq.0) istart = 1 + do 220 l=1,nplusu +c add a new knot in the u-direction + call fpknot(u,mu,tu,nu,fpintu,nrdatu,nrintu,nuest,istart) +c test whether we cannot further increase the number of knots in the +c u-direction. + if(nu.eq.nue) go to 270 + 220 continue + go to 270 + 230 if(nv.eq.nve) go to 210 +c addition in the v-direction. + lastdi = 1 + nplusv = nplv + ifsv = 0 + do 240 l=1,nplusv +c add a new knot in the v-direction. + call fpknot(v,mv,tv,nv,fpintv,nrdatv,nrintv,nvest,1) +c test whether we cannot further increase the number of knots in the +c v-direction. + if(nv.eq.nve) go to 270 + 240 continue +c restart the computations with the new set of knots. + 270 continue +c test whether the least-squares polynomial is a solution of our +c approximation problem. + 300 if(ier.eq.(-2)) go to 440 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline sp(u,v) c +c ***************************************************** c +c we have determined the number of knots and their position. we now c +c compute the b-spline coefficients of the smoothing spline sp(u,v). c +c this smoothing spline depends on the parameter p in such a way that c +c f(p) = sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2) c +c is a continuous, strictly decreasing function of p. moreover the c +c least-squares polynomial corresponds to p=0 and the least-squares c +c spline to p=infinity. then iteratively we have to determine the c +c positive value of p such that f(p)=s. the process which is proposed c +c here makes use of rational interpolation. f(p) is approximated by a c +c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c +c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c +c are used to calculate the new value of p such that r(p)=s. c +c convergence is guaranteed by taking f1 > 0 and f3 < 0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c initial value for p. + p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + p = one + dzz(1) = dz(1) + dzz(2) = dz(2) + dzz(3) = dz(3) + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p)=s. + do 350 iter = 1,maxit +c find the smoothing spline sp(u,v) and the corresponding sum f(p). + call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dzz,iopt,idd, + * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, + * wrk,lwrk) +c test whether the approximation sp(u,v) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c test whether the maximum allowable number of iterations has been +c reached. + if(iter.eq.maxit) go to 400 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 320 + if((f2-f3).gt.acc) go to 310 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 + p2*con1 + go to 350 + 310 if(f2.lt.0.) ich3 = 1 + 320 if(ich1.ne.0) go to 340 + if((f1-f2).gt.acc) go to 330 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 350 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 350 +c test whether the iteration process proceeds as theoretically +c expected. + 330 if(f2.gt.0.) ich1 = 1 + 340 if(f2.ge.f1 .or. f2.le.f3) go to 410 +c find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 350 continue +c error codes and messages. + 400 ier = 3 + go to 440 + 410 ier = 2 + go to 440 + 420 ier = 1 + go to 440 + 430 ier = -1 + fp = 0. + 440 return + end diff --git a/fitpack/fppola.f b/fitpack/fppola.f new file mode 100644 index 0000000..6ec5b01 --- /dev/null +++ b/fitpack/fppola.f @@ -0,0 +1,841 @@ + recursive subroutine fppola(iopt1,iopt2,iopt3,m,u,v,z,w,rad,s, + * nuest,nvest,eta,tol,maxit,ib1,ib3,nc,ncc,intest,nrest,nu,tu,nv, + * tv,c,fp,sup,fpint,coord,f,ff,row,cs,cosi,a,q,bu,bv,spu,spv,h, + * index,nummer,wrk,lwrk,ier) + implicit none +c ..scalar arguments.. + integer iopt1,iopt2,iopt3,m,nuest,nvest,maxit,ib1,ib3,nc,ncc, + * intest,nrest,nu,nv,lwrk,ier + real*8 s,eta,tol,fp,sup +c ..array arguments.. + integer index(nrest),nummer(m) + real*8 u(m),v(m),z(m),w(m),tu(nuest),tv(nvest),c(nc),fpint(intest) + *, + * coord(intest),f(ncc),ff(nc),row(nvest),cs(nvest),cosi(5,nvest), + * a(ncc,ib1),q(ncc,ib3),bu(nuest,5),bv(nvest,5),spu(m,4),spv(m,4), + * h(ib3),wrk(lwrk) +c ..user supplied function.. + real*8 rad +c ..local scalars.. + real*8 acc,arg,co,c1,c2,c3,c4,dmax,eps,fac,fac1,fac2,fpmax,fpms, + * f1,f2,f3,hui,huj,p,pi,pinv,piv,pi2,p1,p2,p3,r,ratio,si,sigma, + * sq,store,uu,u2,u3,wi,zi,rn,one,two,three,con1,con4,con9,half,ten + integer i,iband,iband3,iband4,ich1,ich3,ii,il,in,ipar,ipar1,irot, + * iter,i1,i2,i3,j,jrot,j1,j2,k,l,la,lf,lh,ll,lu,lv,lwest,l1,l2, + * l3,l4,ncof,ncoff,nvv,nv4,nreg,nrint,nrr,nr1,nuu,nu4,num,num1, + * numin,nvmin,rank,iband1, jlu +c ..local arrays.. + real*8 hu(4),hv(4) +c ..function references.. + real*8 abs,atan,cos,fprati,sin,sqrt + integer min0 +c ..subroutine references.. +c fporde,fpbspl,fpback,fpgivs,fprota,fprank,fpdisc,fprppo +c .. +c set constants + one = 1 + two = 2 + three = 3 + ten = 10 + half = 0.5e0 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 + pi = atan(one)*4 + pi2 = pi+pi + ipar = iopt2*(iopt2+3)/2 + ipar1 = ipar+1 + eps = sqrt(eta) + if(iopt1.lt.0) go to 90 + numin = 9 + nvmin = 9+iopt2*(iopt2+1) +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s + if(iopt1.eq.0) go to 10 + if(s.lt.sup) then + if (nv.lt.nvmin) go to 70 + go to 90 + endif +c if iopt1 = 0 we begin by computing the weighted least-squares +c polymomial of the form +c s(u,v) = f(1)*(1-u**3)+f(2)*u**3+f(3)*(u**2-u**3)+f(4)*(u-u**3) +c where f(4) = 0 if iopt2> 0 , f(3) = 0 if iopt2 > 1 and +c f(2) = 0 if iopt3> 0. +c the corresponding weighted sum of squared residuals gives the upper +c bound sup for the smoothing factor s. + 10 sup = 0. + do 20 i=1,4 + f(i) = 0. + do 20 j=1,4 + a(i,j) = 0. + 20 continue + do 50 i=1,m + wi = w(i) + zi = z(i)*wi + uu = u(i) + u2 = uu*uu + u3 = uu*u2 + h(1) = (one-u3)*wi + h(2) = u3*wi + h(3) = u2*(one-uu)*wi + h(4) = uu*(one-u2)*wi + if(iopt3.ne.0) h(2) = 0. + if(iopt2.gt.1) h(3) = 0. + if(iopt2.gt.0) h(4) = 0. + do 40 j=1,4 + piv = h(j) + if(piv.eq.0.) go to 40 + call fpgivs(piv,a(j,1),co,si) + call fprota(co,si,zi,f(j)) + if(j.eq.4) go to 40 + j1 = j+1 + j2 = 1 + do 30 l=j1,4 + j2 = j2+1 + call fprota(co,si,h(l),a(j,j2)) + 30 continue + 40 continue + sup = sup+zi*zi + 50 continue + if(a(4,1).ne.0.) f(4) = f(4)/a(4,1) + if(a(3,1).ne.0.) f(3) = (f(3)-a(3,2)*f(4))/a(3,1) + if(a(2,1).ne.0.) f(2) = (f(2)-a(2,2)*f(3)-a(2,3)*f(4))/a(2,1) + if(a(1,1).ne.0.) + * f(1) = (f(1)-a(1,2)*f(2)-a(1,3)*f(3)-a(1,4)*f(4))/a(1,1) +c find the b-spline representation of this least-squares polynomial + c1 = f(1) + c4 = f(2) + c2 = f(4)/three+c1 + c3 = (f(3)+two*f(4))/three+c1 + nu = 8 + nv = 8 + do 60 i=1,4 + c(i) = c1 + c(i+4) = c2 + c(i+8) = c3 + c(i+12) = c4 + tu(i) = 0. + tu(i+4) = one + rn = 2*i-9 + tv(i) = rn*pi + rn = 2*i-1 + tv(i+4) = rn*pi + 60 continue + fp = sup +c test whether the least-squares polynomial is an acceptable solution + fpms = sup-s + if(fpms.lt.acc) go to 960 +c test whether we cannot further increase the number of knots. + 70 if(nuest.lt.numin .or. nvest.lt.nvmin) go to 950 +c find the initial set of interior knots of the spline in case iopt1=0. + nu = numin + nv = nvmin + tu(5) = half + nvv = nv-8 + rn = nvv+1 + fac = pi2/rn + do 80 i=1,nvv + rn = i + tv(i+4) = rn*fac-pi + 80 continue +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 1 : computation of least-squares bicubic splines. c +c ****************************************************** c +c if iopt1<0 we compute the least-squares bicubic spline according c +c to the given set of knots. c +c if iopt1>=0 we compute least-squares bicubic splines with in- c +c creasing numbers of knots until the corresponding sum f(p=inf)<=s. c +c the initial set of knots then depends on the value of iopt1 c +c if iopt1=0 we start with one interior knot in the u-direction c +c (0.5) and 1+iopt2*(iopt2+1) in the v-direction. c +c if iopt1>0 we start with the set of knots found at the last c +c call of the routine. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c main loop for the different sets of knots. m is a save upper bound +c for the number of trials. + 90 do 570 iter=1,m +c find the position of the additional knots which are needed for the +c b-spline representation of s(u,v). + l1 = 4 + l2 = l1 + l3 = nv-3 + l4 = l3 + tv(l2) = -pi + tv(l3) = pi + do 120 i=1,3 + l1 = l1+1 + l2 = l2-1 + l3 = l3+1 + l4 = l4-1 + tv(l2) = tv(l4)-pi2 + tv(l3) = tv(l1)+pi2 + 120 continue + l = nu + do 130 i=1,4 + tu(i) = 0. + tu(l) = one + l = l-1 + 130 continue +c find nrint, the total number of knot intervals and nreg, the number +c of panels in which the approximation domain is subdivided by the +c intersection of knots. + nuu = nu-7 + nvv = nv-7 + nrr = nvv/2 + nr1 = nrr+1 + nrint = nuu+nvv + nreg = nuu*nvv +c arrange the data points according to the panel they belong to. + call fporde(u,v,m,3,3,tu,nu,tv,nv,nummer,index,nreg) + if(iopt2.eq.0) go to 195 +c find the b-spline coefficients cosi of the cubic spline +c approximations for cr(v)=rad(v)*cos(v) and sr(v) = rad(v)*sin(v) +c if iopt2=1, and additionally also for cr(v)**2,sr(v)**2 and +c 2*cr(v)*sr(v) if iopt2=2 + do 140 i=1,nvv + do 135 j=1,ipar + cosi(j,i) = 0. + 135 continue + do 140 j=1,nvv + a(i,j) = 0. + 140 continue +c the coefficients cosi are obtained from interpolation conditions +c at the knots tv(i),i=4,5,...nv-4. + do 175 i=1,nvv + l2 = i+3 + arg = tv(l2) + call fpbspl(tv,nv,3,arg,l2,hv) + do 145 j=1,nvv + row(j) = 0. + 145 continue + ll = i + do 150 j=1,3 + if(ll.gt.nvv) ll= 1 + row(ll) = row(ll)+hv(j) + ll = ll+1 + 150 continue + co = cos(arg) + si = sin(arg) + r = rad(arg) + cs(1) = co*r + cs(2) = si*r + if(iopt2.eq.1) go to 155 + cs(3) = cs(1)*cs(1) + cs(4) = cs(2)*cs(2) + cs(5) = cs(1)*cs(2) + 155 do 170 j=1,nvv + piv = row(j) + if(piv.eq.0.) go to 170 + call fpgivs(piv,a(j,1),co,si) + do 160 l=1,ipar + call fprota(co,si,cs(l),cosi(l,j)) + 160 continue + if(j.eq.nvv) go to 175 + j1 = j+1 + j2 = 1 + do 165 l=j1,nvv + j2 = j2+1 + call fprota(co,si,row(l),a(j,j2)) + 165 continue + 170 continue + 175 continue + do 190 l=1,ipar + do 180 j=1,nvv + cs(j) = cosi(l,j) + 180 continue + call fpback(a,cs,nvv,nvv,cs,ncc) + do 185 j=1,nvv + cosi(l,j) = cs(j) + 185 continue + 190 continue +c find ncof, the dimension of the spline and ncoff, the number +c of coefficients in the standard b-spline representation. + 195 nu4 = nu-4 + nv4 = nv-4 + ncoff = nu4*nv4 + ncof = ipar1+nvv*(nu4-1-iopt2-iopt3) +c find the bandwidth of the observation matrix a. + iband = 4*nvv + if(nuu-iopt2-iopt3.le.1) iband = ncof + iband1 = iband-1 +c initialize the observation matrix a. + do 200 i=1,ncof + f(i) = 0. + do 200 j=1,iband + a(i,j) = 0. + 200 continue +c initialize the sum of squared residuals. + fp = 0. + ratio = one+tu(6)/tu(5) +c fetch the data points in the new order. main loop for the +c different panels. + do 380 num=1,nreg +c fix certain constants for the current panel; jrot records the column +c number of the first non-zero element in a row of the observation +c matrix according to a data point of the panel. + num1 = num-1 + lu = num1/nvv + l1 = lu+4 + lv = num1-lu*nvv+1 + l2 = lv+3 + jrot = 0 + if(lu.gt.iopt2) jrot = ipar1+(lu-iopt2-1)*nvv + lu = lu+1 +c test whether there are still data points in the current panel. + in = index(num) + 210 if(in.eq.0) go to 380 +c fetch a new data point. + wi = w(in) + zi = z(in)*wi +c evaluate for the u-direction, the 4 non-zero b-splines at u(in) + call fpbspl(tu,nu,3,u(in),l1,hu) +c evaluate for the v-direction, the 4 non-zero b-splines at v(in) + call fpbspl(tv,nv,3,v(in),l2,hv) +c store the value of these b-splines in spu and spv resp. + do 220 i=1,4 + spu(in,i) = hu(i) + spv(in,i) = hv(i) + 220 continue +c initialize the new row of observation matrix. + do 240 i=1,iband + h(i) = 0. + 240 continue +c calculate the non-zero elements of the new row by making the cross +c products of the non-zero b-splines in u- and v-direction and +c by taking into account the conditions of the splines. + do 250 i=1,nvv + row(i) = 0. + 250 continue +c take into account the periodicity condition of the bicubic splines. + ll = lv + do 260 i=1,4 + if(ll.gt.nvv) ll=1 + row(ll) = row(ll)+hv(i) + ll = ll+1 + 260 continue +c take into account the other conditions of the splines. + if(iopt2.eq.0 .or. lu.gt.iopt2+1) go to 280 + do 270 l=1,ipar + cs(l) = 0. + do 270 i=1,nvv + cs(l) = cs(l)+row(i)*cosi(l,i) + 270 continue +c fill in the non-zero elements of the new row. + 280 j1 = 0 + do 330 j =1,4 + jlu = j+lu + huj = hu(j) + if(jlu.gt.iopt2+2) go to 320 + go to (290,290,300,310),jlu + 290 h(1) = huj + j1 = 1 + go to 330 + 300 h(1) = h(1)+huj + h(2) = huj*cs(1) + h(3) = huj*cs(2) + j1 = 3 + go to 330 + 310 h(1) = h(1)+huj + h(2) = h(2)+huj*ratio*cs(1) + h(3) = h(3)+huj*ratio*cs(2) + h(4) = huj*cs(3) + h(5) = huj*cs(4) + h(6) = huj*cs(5) + j1 = 6 + go to 330 + 320 if(jlu.gt.nu4 .and. iopt3.ne.0) go to 330 + do 325 i=1,nvv + j1 = j1+1 + h(j1) = row(i)*huj + 325 continue + 330 continue + do 335 i=1,iband + h(i) = h(i)*wi + 335 continue +c rotate the row into triangle by givens transformations. + irot = jrot + do 350 i=1,iband + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 350 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(irot,1),co,si) +c apply that transformation to the right hand side. + call fprota(co,si,zi,f(irot)) + if(i.eq.iband) go to 360 +c apply that transformation to the left hand side. + i2 = 1 + i3 = i+1 + do 340 j=i3,iband + i2 = i2+1 + call fprota(co,si,h(j),a(irot,i2)) + 340 continue + 350 continue +c add the contribution of the row to the sum of squares of residual +c right hand sides. + 360 fp = fp+zi**2 +c find the number of the next data point in the panel. + in = nummer(in) + go to 210 + 380 continue +c find dmax, the maximum value for the diagonal elements in the reduced +c triangle. + dmax = 0. + do 390 i=1,ncof + if(a(i,1).le.dmax) go to 390 + dmax = a(i,1) + 390 continue +c check whether the observation matrix is rank deficient. + sigma = eps*dmax + do 400 i=1,ncof + if(a(i,1).le.sigma) go to 410 + 400 continue +c backward substitution in case of full rank. + call fpback(a,f,ncof,iband,c,ncc) + rank = ncof + do 405 i=1,ncof + q(i,1) = a(i,1)/dmax + 405 continue + go to 430 +c in case of rank deficiency, find the minimum norm solution. + 410 lwest = ncof*iband+ncof+iband + if(lwrk.lt.lwest) go to 925 + lf = 1 + lh = lf+ncof + la = lh+iband + do 420 i=1,ncof + ff(i) = f(i) + do 420 j=1,iband + q(i,j) = a(i,j) + 420 continue + call fprank(q,ff,ncof,iband,ncc,sigma,c,sq,rank,wrk(la), + * wrk(lf),wrk(lh)) + do 425 i=1,ncof + q(i,1) = q(i,1)/dmax + 425 continue +c add to the sum of squared residuals, the contribution of reducing +c the rank. + fp = fp+sq +c find the coefficients in the standard b-spline representation of +c the spline. + 430 call fprppo(nu,nv,iopt2,iopt3,cosi,ratio,c,ff,ncoff) +c test whether the least-squares spline is an acceptable solution. + if(iopt1.lt.0) then + if (fp.le.0) go to 970 + go to 980 + endif + fpms = fp-s + if(abs(fpms).le.acc) then + if (fp.le.0) go to 970 + go to 980 + endif +c if f(p=inf) < s, accept the choice of knots. + if(fpms.lt.0.) go to 580 +c test whether we cannot further increase the number of knots + if(m.lt.ncof) go to 935 +c search where to add a new knot. +c find for each interval the sum of squared residuals fpint for the +c data points having the coordinate belonging to that knot interval. +c calculate also coord which is the same sum, weighted by the position +c of the data points considered. + do 450 i=1,nrint + fpint(i) = 0. + coord(i) = 0. + 450 continue + do 490 num=1,nreg + num1 = num-1 + lu = num1/nvv + l1 = lu+1 + lv = num1-lu*nvv + l2 = lv+1+nuu + jrot = lu*nv4+lv + in = index(num) + 460 if(in.eq.0) go to 490 + store = 0. + i1 = jrot + do 480 i=1,4 + hui = spu(in,i) + j1 = i1 + do 470 j=1,4 + j1 = j1+1 + store = store+hui*spv(in,j)*c(j1) + 470 continue + i1 = i1+nv4 + 480 continue + store = (w(in)*(z(in)-store))**2 + fpint(l1) = fpint(l1)+store + coord(l1) = coord(l1)+store*u(in) + fpint(l2) = fpint(l2)+store + coord(l2) = coord(l2)+store*v(in) + in = nummer(in) + go to 460 + 490 continue +c bring together the information concerning knot panels which are +c symmetric with respect to the origin. + do 495 i=1,nrr + l1 = nuu+i + l2 = l1+nrr + fpint(l1) = fpint(l1)+fpint(l2) + coord(l1) = coord(l1)+coord(l2)-pi*fpint(l2) + 495 continue +c find the interval for which fpint is maximal on the condition that +c there still can be added a knot. + l1 = 1 + l2 = nuu+nrr + if(nuest.lt.nu+1) l1=nuu+1 + if(nvest.lt.nv+2) l2=nuu +c test whether we cannot further increase the number of knots. + if(l1.gt.l2) go to 950 + 500 fpmax = 0. + l = 0 + do 510 i=l1,l2 + if(fpmax.ge.fpint(i)) go to 510 + l = i + fpmax = fpint(i) + 510 continue + if(l.eq.0) go to 930 +c calculate the position of the new knot. + arg = coord(l)/fpint(l) +c test in what direction the new knot is going to be added. + if(l.gt.nuu) go to 530 +c addition in the u-direction + l4 = l+4 + fpint(l) = 0. + fac1 = tu(l4)-arg + fac2 = arg-tu(l4-1) + if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500 + j = nu + do 520 i=l4,nu + tu(j+1) = tu(j) + j = j-1 + 520 continue + tu(l4) = arg + nu = nu+1 + go to 570 +c addition in the v-direction + 530 l4 = l+4-nuu + fpint(l) = 0. + fac1 = tv(l4)-arg + fac2 = arg-tv(l4-1) + if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500 + ll = nrr+4 + j = ll + do 550 i=l4,ll + tv(j+1) = tv(j) + j = j-1 + 550 continue + tv(l4) = arg + nv = nv+2 + nrr = nrr+1 + do 560 i=5,ll + j = i+nrr + tv(j) = tv(i)+pi + 560 continue +c restart the computations with the new set of knots. + 570 continue +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing bicubic spline. c +c ****************************************************** c +c we have determined the number of knots and their position. we now c +c compute the coefficients of the smoothing spline sp(u,v). c +c the observation matrix a is extended by the rows of a matrix, expres-c +c sing that sp(u,v) must be a constant function in the variable c +c v and a cubic polynomial in the variable u. the corresponding c +c weights of these additional rows are set to 1/(p). iteratively c +c we than have to determine the value of p such that f(p) = sum((w(i)* c +c (z(i)-sp(u(i),v(i))))**2) be = s. c +c we already know that the least-squares polynomial corresponds to p=0,c +c and that the least-squares bicubic spline corresponds to p=infin. c +c the iteration process makes use of rational interpolation. since f(p)c +c is a convex and strictly decreasing function of p, it can be approx- c +c imated by a rational function of the form r(p) = (u*p+v)/(p+w). c +c three values of p (p1,p2,p3) with corresponding values of f(p) (f1= c +c f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the new value c +c of p such that r(p)=s. convergence is guaranteed by taking f1>0,f3<0.c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c evaluate the discontinuity jumps of the 3-th order derivative of +c the b-splines at the knots tu(l),l=5,...,nu-4. + 580 call fpdisc(tu,nu,5,bu,nuest) +c evaluate the discontinuity jumps of the 3-th order derivative of +c the b-splines at the knots tv(l),l=5,...,nv-4. + call fpdisc(tv,nv,5,bv,nvest) +c initial value for p. + p1 = 0. + f1 = sup-s + p3 = -one + f3 = fpms + p = 0. + do 590 i=1,ncof + p = p+a(i,1) + 590 continue + rn = ncof + p = rn/p +c find the bandwidth of the extended observation matrix. + iband4 = iband+ipar1 + if(iband4.gt.ncof) iband4 = ncof + iband3 = iband4 -1 + ich1 = 0 + ich3 = 0 + nuu = nu4-iopt3-1 +c iteration process to find the root of f(p)=s. + do 920 iter=1,maxit + pinv = one/p +c store the triangularized observation matrix into q. + do 630 i=1,ncof + ff(i) = f(i) + do 620 j=1,iband4 + q(i,j) = 0. + 620 continue + do 630 j=1,iband + q(i,j) = a(i,j) + 630 continue +c extend the observation matrix with the rows of a matrix, expressing +c that for u=constant sp(u,v) must be a constant function. + do 720 i=5,nv4 + ii = i-4 + do 635 l=1,nvv + row(l) = 0. + 635 continue + ll = ii + do 640 l=1,5 + if(ll.gt.nvv) ll=1 + row(ll) = row(ll)+bv(ii,l) + ll = ll+1 + 640 continue + do 720 j=1,nuu +c initialize the new row. + do 645 l=1,iband + h(l) = 0. + 645 continue +c fill in the non-zero elements of the row. jrot records the column +c number of the first non-zero element in the row. + if(j.gt.iopt2) go to 665 + if(j.eq.2) go to 655 + do 650 k=1,2 + cs(k) = 0. + do 650 l=1,nvv + cs(k) = cs(k)+cosi(k,l)*row(l) + 650 continue + h(1) = cs(1) + h(2) = cs(2) + jrot = 2 + go to 675 + 655 do 660 k=3,5 + cs(k) = 0. + do 660 l=1,nvv + cs(k) = cs(k)+cosi(k,l)*row(l) + 660 continue + h(1) = cs(1)*ratio + h(2) = cs(2)*ratio + h(3) = cs(3) + h(4) = cs(4) + h(5) = cs(5) + jrot = 2 + go to 675 + 665 do 670 l=1,nvv + h(l) = row(l) + 670 continue + jrot = ipar1+1+(j-iopt2-1)*nvv + 675 do 677 l=1,iband + h(l) = h(l)*pinv + 677 continue + zi = 0. +c rotate the new row into triangle by givens transformations. + do 710 irot=jrot,ncof + piv = h(1) + i2 = min0(iband1,ncof-irot) + if(piv.eq.0.) then + if (i2.le.0) go to 720 + go to 690 + endif +c calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),co,si) +c apply that givens transformation to the right hand side. + call fprota(co,si,zi,ff(irot)) + if(i2.eq.0) go to 720 +c apply that givens transformation to the left hand side. + do 680 l=1,i2 + l1 = l+1 + call fprota(co,si,h(l1),q(irot,l1)) + 680 continue + 690 do 700 l=1,i2 + h(l) = h(l+1) + 700 continue + h(i2+1) = 0. + 710 continue + 720 continue +c extend the observation matrix with the rows of a matrix expressing +c that for v=constant. sp(u,v) must be a cubic polynomial. + do 810 i=5,nu4 + ii = i-4 + do 810 j=1,nvv +c initialize the new row + do 730 l=1,iband4 + h(l) = 0. + 730 continue +c fill in the non-zero elements of the row. jrot records the column +c number of the first non-zero element in the row. + j1 = 1 + do 760 l=1,5 + il = ii+l-1 + if(il.eq.nu4 .and. iopt3.ne.0) go to 760 + if(il.gt.iopt2+1) go to 750 + go to (735,740,745),il + 735 h(1) = bu(ii,l) + j1 = j+1 + go to 760 + 740 h(1) = h(1)+bu(ii,l) + h(2) = bu(ii,l)*cosi(1,j) + h(3) = bu(ii,l)*cosi(2,j) + j1 = j+3 + go to 760 + 745 h(1) = h(1)+bu(ii,l) + h(2) = bu(ii,l)*cosi(1,j)*ratio + h(3) = bu(ii,l)*cosi(2,j)*ratio + h(4) = bu(ii,l)*cosi(3,j) + h(5) = bu(ii,l)*cosi(4,j) + h(6) = bu(ii,l)*cosi(5,j) + j1 = j+6 + go to 760 + 750 h(j1) = bu(ii,l) + j1 = j1+nvv + 760 continue + do 765 l=1,iband4 + h(l) = h(l)*pinv + 765 continue + zi = 0. + jrot = 1 + if(ii.gt.iopt2+1) jrot = ipar1+(ii-iopt2-2)*nvv+j +c rotate the new row into triangle by givens transformations. + do 800 irot=jrot,ncof + piv = h(1) + i2 = min0(iband3,ncof-irot) + if(piv.eq.0.) then + if (i2.le.0) go to 810 + go to 780 + endif +c calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),co,si) +c apply that givens transformation to the right hand side. + call fprota(co,si,zi,ff(irot)) + if(i2.eq.0) go to 810 +c apply that givens transformation to the left hand side. + do 770 l=1,i2 + l1 = l+1 + call fprota(co,si,h(l1),q(irot,l1)) + 770 continue + 780 do 790 l=1,i2 + h(l) = h(l+1) + 790 continue + h(i2+1) = 0. + 800 continue + 810 continue +c find dmax, the maximum value for the diagonal elements in the +c reduced triangle. + dmax = 0. + do 820 i=1,ncof + if(q(i,1).le.dmax) go to 820 + dmax = q(i,1) + 820 continue +c check whether the matrix is rank deficient. + sigma = eps*dmax + do 830 i=1,ncof + if(q(i,1).le.sigma) go to 840 + 830 continue +c backward substitution in case of full rank. + call fpback(q,ff,ncof,iband4,c,ncc) + rank = ncof + go to 845 +c in case of rank deficiency, find the minimum norm solution. + 840 lwest = ncof*iband4+ncof+iband4 + if(lwrk.lt.lwest) go to 925 + lf = 1 + lh = lf+ncof + la = lh+iband4 + call fprank(q,ff,ncof,iband4,ncc,sigma,c,sq,rank,wrk(la), + * wrk(lf),wrk(lh)) + 845 do 850 i=1,ncof + q(i,1) = q(i,1)/dmax + 850 continue +c find the coefficients in the standard b-spline representation of +c the polar spline. + call fprppo(nu,nv,iopt2,iopt3,cosi,ratio,c,ff,ncoff) +c compute f(p). + fp = 0. + do 890 num = 1,nreg + num1 = num-1 + lu = num1/nvv + lv = num1-lu*nvv + jrot = lu*nv4+lv + in = index(num) + 860 if(in.eq.0) go to 890 + store = 0. + i1 = jrot + do 880 i=1,4 + hui = spu(in,i) + j1 = i1 + do 870 j=1,4 + j1 = j1+1 + store = store+hui*spv(in,j)*c(j1) + 870 continue + i1 = i1+nv4 + 880 continue + fp = fp+(w(in)*(z(in)-store))**2 + in = nummer(in) + go to 860 + 890 continue +c test whether the approximation sp(u,v) is an acceptable solution + fpms = fp-s + if(abs(fpms).le.acc) go to 980 +c test whether the maximum allowable number of iterations has been +c reached. + if(iter.eq.maxit) go to 940 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 900 + if((f2-f3).gt.acc) go to 895 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 + p2*con1 + go to 920 + 895 if(f2.lt.0.) ich3 = 1 + 900 if(ich1.ne.0) go to 910 + if((f1-f2).gt.acc) go to 905 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 920 + if(p.ge.p3) p = p2*con1 +p3*con9 + go to 920 + 905 if(f2.gt.0.) ich1 = 1 +c test whether the iteration process proceeds as theoretically +c expected. + 910 if(f2.ge.f1 .or. f2.le.f3) go to 945 +c find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 920 continue +c error codes and messages. + 925 ier = lwest + go to 990 + 930 ier = 5 + go to 990 + 935 ier = 4 + go to 990 + 940 ier = 3 + go to 990 + 945 ier = 2 + go to 990 + 950 ier = 1 + go to 990 + 960 ier = -2 + go to 990 + 970 ier = -1 + fp = 0. + 980 if(ncof.ne.rank) ier = -rank + 990 return + end + diff --git a/fitpack/fprank.f b/fitpack/fprank.f new file mode 100644 index 0000000..3f46321 --- /dev/null +++ b/fitpack/fprank.f @@ -0,0 +1,237 @@ + recursive subroutine fprank(a,f,n,m,na,tol,c,sq,rank,aa,ff,h) + implicit none +c subroutine fprank finds the minimum norm solution of a least- +c squares problem in case of rank deficiency. +c +c input parameters: +c a : array, which contains the non-zero elements of the observation +c matrix after triangularization by givens transformations. +c f : array, which contains the transformed right hand side. +c n : integer,which contains the dimension of a. +c m : integer, which denotes the bandwidth of a. +c tol : real value, giving a threshold to determine the rank of a. +c +c output parameters: +c c : array, which contains the minimum norm solution. +c sq : real value, giving the contribution of reducing the rank +c to the sum of squared residuals. +c rank : integer, which contains the rank of matrix a. +c +c ..scalar arguments.. + integer n,m,na,rank + real*8 tol,sq +c ..array arguments.. + real*8 a(na,m),f(n),c(n),aa(n,m),ff(n),h(m) +c ..local scalars.. + integer i,ii,ij,i1,i2,j,jj,j1,j2,j3,k,kk,m1,nl + real*8 cos,fac,piv,sin,yi + double precision store,stor1,stor2,stor3 +c ..function references.. + integer min0 +c ..subroutine references.. +c fpgivs,fprota +c .. + m1 = m-1 +c the rank deficiency nl is considered to be the number of sufficient +c small diagonal elements of a. + nl = 0 + sq = 0. + do 90 i=1,n + if(a(i,1).gt.tol) go to 90 +c if a sufficient small diagonal element is found, we put it to +c zero. the remainder of the row corresponding to that zero diagonal +c element is then rotated into triangle by givens rotations . +c the rank deficiency is increased by one. + nl = nl+1 + if(i.eq.n) go to 90 + yi = f(i) + do 10 j=1,m1 + h(j) = a(i,j+1) + 10 continue + h(m) = 0. + i1 = i+1 + do 60 ii=i1,n + i2 = min0(n-ii,m1) + piv = h(1) + if(piv.eq.0.) go to 30 + call fpgivs(piv,a(ii,1),cos,sin) + call fprota(cos,sin,yi,f(ii)) + if(i2.eq.0) go to 70 + do 20 j=1,i2 + j1 = j+1 + call fprota(cos,sin,h(j1),a(ii,j1)) + h(j) = h(j1) + 20 continue + go to 50 + 30 if(i2.eq.0) go to 70 + do 40 j=1,i2 + h(j) = h(j+1) + 40 continue + 50 h(i2+1) = 0. + 60 continue +c add to the sum of squared residuals the contribution of deleting +c the row with small diagonal element. + 70 sq = sq+yi**2 + 90 continue +c rank denotes the rank of a. + rank = n-nl +c let b denote the (rank*n) upper trapezoidal matrix which can be +c obtained from the (n*n) upper triangular matrix a by deleting +c the rows and interchanging the columns corresponding to a zero +c diagonal element. if this matrix is factorized using givens +c transformations as b = (r) (u) where +c r is a (rank*rank) upper triangular matrix, +c u is a (rank*n) orthonormal matrix +c then the minimal least-squares solution c is given by c = b' v, +c where v is the solution of the system (r) (r)' v = g and +c g denotes the vector obtained from the old right hand side f, by +c removing the elements corresponding to a zero diagonal element of a. +c initialization. + do 100 i=1,rank + do 100 j=1,m + aa(i,j) = 0. + 100 continue +c form in aa the upper triangular matrix obtained from a by +c removing rows and columns with zero diagonal elements. form in ff +c the new right hand side by removing the elements of the old right +c hand side corresponding to a deleted row. + ii = 0 + do 120 i=1,n + if(a(i,1).le.tol) go to 120 + ii = ii+1 + ff(ii) = f(i) + aa(ii,1) = a(i,1) + jj = ii + kk = 1 + j = i + j1 = min0(j-1,m1) + if(j1.eq.0) go to 120 + do 110 k=1,j1 + j = j-1 + if(a(j,1).le.tol) go to 110 + kk = kk+1 + jj = jj-1 + aa(jj,kk) = a(j,k+1) + 110 continue + 120 continue +c form successively in h the columns of a with a zero diagonal element. + ii = 0 + do 200 i=1,n + ii = ii+1 + if(a(i,1).gt.tol) go to 200 + ii = ii-1 + if(ii.eq.0) go to 200 + jj = 1 + j = i + j1 = min0(j-1,m1) + do 130 k=1,j1 + j = j-1 + if(a(j,1).le.tol) go to 130 + h(jj) = a(j,k+1) + jj = jj+1 + 130 continue + do 140 kk=jj,m + h(kk) = 0. + 140 continue +c rotate this column into aa by givens transformations. + jj = ii + do 190 i1=1,ii + j1 = min0(jj-1,m1) + piv = h(1) + if(piv.ne.0.) go to 160 + if(j1.eq.0) go to 200 + do 150 j2=1,j1 + j3 = j2+1 + h(j2) = h(j3) + 150 continue + go to 180 + 160 call fpgivs(piv,aa(jj,1),cos,sin) + if(j1.eq.0) go to 200 + kk = jj + do 170 j2=1,j1 + j3 = j2+1 + kk = kk-1 + call fprota(cos,sin,h(j3),aa(kk,j3)) + h(j2) = h(j3) + 170 continue + 180 jj = jj-1 + h(j3) = 0. + 190 continue + 200 continue +c solve the system (aa) (f1) = ff + ff(rank) = ff(rank)/aa(rank,1) + i = rank-1 + if(i.eq.0) go to 230 + do 220 j=2,rank + store = ff(i) + i1 = min0(j-1,m1) + k = i + do 210 ii=1,i1 + k = k+1 + stor1 = ff(k) + stor2 = aa(i,ii+1) + store = store-stor1*stor2 + 210 continue + stor1 = aa(i,1) + ff(i) = store/stor1 + i = i-1 + 220 continue +c solve the system (aa)' (f2) = f1 + 230 ff(1) = ff(1)/aa(1,1) + if(rank.eq.1) go to 260 + do 250 j=2,rank + store = ff(j) + i1 = min0(j-1,m1) + k = j + do 240 ii=1,i1 + k = k-1 + stor1 = ff(k) + stor2 = aa(k,ii+1) + store = store-stor1*stor2 + 240 continue + stor1 = aa(j,1) + ff(j) = store/stor1 + 250 continue +c premultiply f2 by the transpoze of a. + 260 k = 0 + do 280 i=1,n + store = 0. + if(a(i,1).gt.tol) k = k+1 + j1 = min0(i,m) + kk = k + ij = i+1 + do 270 j=1,j1 + ij = ij-1 + if(a(ij,1).le.tol) go to 270 + stor1 = a(ij,j) + stor2 = ff(kk) + store = store+stor1*stor2 + kk = kk-1 + 270 continue + c(i) = store + 280 continue +c add to the sum of squared residuals the contribution of putting +c to zero the small diagonal elements of matrix (a). + stor3 = 0. + do 310 i=1,n + if(a(i,1).gt.tol) go to 310 + store = f(i) + i1 = min0(n-i,m1) + if(i1.eq.0) go to 300 + do 290 j=1,i1 + ij = i+j + stor1 = c(ij) + stor2 = a(i,j+1) + store = store-stor1*stor2 + 290 continue + 300 fac = a(i,1)*c(i) + stor1 = a(i,1) + stor2 = c(i) + stor1 = stor1*stor2 + stor3 = stor3+stor1*(stor1-store-store) + 310 continue + fac = stor3 + sq = sq+fac + return + end + diff --git a/fitpack/fprati.f b/fitpack/fprati.f new file mode 100644 index 0000000..71c57eb --- /dev/null +++ b/fitpack/fprati.f @@ -0,0 +1,31 @@ + recursive function fprati(p1,f1,p2,f2,p3,f3) result(fprati_res) + implicit none + real*8 :: fprati_res +c given three points (p1,f1),(p2,f2) and (p3,f3), function fprati +c gives the value of p such that the rational interpolating function +c of the form r(p) = (u*p+v)/(p+w) equals zero at p. +c .. +c ..scalar arguments.. + real*8 p1,f1,p2,f2,p3,f3 +c ..local scalars.. + real*8 h1,h2,h3,p +c .. + if(p3.gt.0.) go to 10 +c value of p in case p3 = infinity. + p = (p1*(f1-f3)*f2-p2*(f2-f3)*f1)/((f1-f2)*f3) + go to 20 +c value of p in case p3 ^= infinity. + 10 h1 = f1*(f2-f3) + h2 = f2*(f3-f1) + h3 = f3*(f1-f2) + p = -(p1*p2*h3+p2*p3*h1+p3*p1*h2)/(p1*h1+p2*h2+p3*h3) +c adjust the value of p1,f1,p3 and f3 such that f1 > 0 and f3 < 0. + 20 if(f2.lt.0.) go to 30 + p1 = p2 + f1 = f2 + go to 40 + 30 p3 = p2 + f3 = f2 + 40 fprati_res = p + return + end diff --git a/fitpack/fpregr.f b/fitpack/fpregr.f new file mode 100644 index 0000000..e43726d --- /dev/null +++ b/fitpack/fpregr.f @@ -0,0 +1,368 @@ + recursive subroutine fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye, + * kx,ky,s,nxest,nyest,tol,maxit,nc,nx,tx,ny,ty,c,fp,fp0,fpold, + * reducx,reducy,fpintx,fpinty,lastdi,nplusx,nplusy,nrx,nry, + * nrdatx,nrdaty,wrk,lwrk,ier) + implicit none +c .. +c ..scalar arguments.. + real*8 xb,xe,yb,ye,s,tol,fp,fp0,fpold,reducx,reducy + integer iopt,mx,my,mz,kx,ky,nxest,nyest,maxit,nc,nx,ny,lastdi, + * nplusx,nplusy,lwrk,ier +c ..array arguments.. + real*8 x(mx),y(my),z(mz),tx(nxest),ty(nyest),c(nc),fpintx(nxest), + * fpinty(nyest),wrk(lwrk) + integer nrdatx(nxest),nrdaty(nyest),nrx(mx),nry(my) +c ..local scalars + real*8 acc,fpms,f1,f2,f3,p,p1,p2,p3,rn,one,half,con1,con9,con4 + integer i,ich1,ich3,ifbx,ifby,ifsx,ifsy,iter,j,kx1,kx2,ky1,ky2, + * k3,l,lax,lay,lbx,lby,lq,lri,lsx,lsy,mk1,mm,mpm,mynx,ncof, + * nk1x,nk1y,nmaxx,nmaxy,nminx,nminy,nplx,nply,npl1,nrintx, + * nrinty,nxe,nxk,nye +c ..function references.. + real*8 abs,fprati + integer max0,min0 +c ..subroutine references.. +c fpgrre,fpknot +c .. +c set constants + one = 1 + half = 0.5e0 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 +c we partition the working space. + kx1 = kx+1 + ky1 = ky+1 + kx2 = kx1+1 + ky2 = ky1+1 + lsx = 1 + lsy = lsx+mx*kx1 + lri = lsy+my*ky1 + mm = max0(nxest,my) + lq = lri+mm + mynx = nxest*my + lax = lq+mynx + nxk = nxest*kx2 + lbx = lax+nxk + lay = lbx+nxk + lby = lay+nyest*ky2 +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 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 s=0 we have spline interpolation; in that case the number of c +c knots equals nmaxx = mx+kx+1 and nmaxy = my+ky+1. c +c if s>0 and c +c *iopt=0 we first compute the least-squares polynomial of degree c +c kx in x and ky in y; nx=nminx=2*kx+2 and ny=nymin=2*ky+2. c +c *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 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c determine the number of knots for polynomial approximation. + nminx = 2*kx1 + nminy = 2*ky1 + if(iopt.lt.0) go to 120 +c acc denotes the absolute tolerance for the root of f(p)=s. + acc = tol*s +c find nmaxx and nmaxy which denote the number of knots in x- and y- +c direction in case of spline interpolation. + nmaxx = mx+kx1 + nmaxy = my+ky1 +c find nxe and nye which denote the maximum number of knots +c allowed in each direction + nxe = min0(nmaxx,nxest) + nye = min0(nmaxy,nyest) + if(s.gt.0.) go to 100 +c if s = 0, s(x,y) is an interpolating spline. + nx = nmaxx + ny = nmaxy +c test whether the required storage space exceeds the available one. + if(ny.gt.nyest .or. nx.gt.nxest) go to 420 +c find the position of the interior knots in case of interpolation. +c the knots in the x-direction. + mk1 = mx-kx1 + if(mk1.eq.0) go to 60 + k3 = kx/2 + i = kx1+1 + j = k3+2 + if(k3*2.eq.kx) go to 40 + do 30 l=1,mk1 + tx(i) = x(j) + i = i+1 + j = j+1 + 30 continue + go to 60 + 40 do 50 l=1,mk1 + tx(i) = (x(j)+x(j-1))*half + i = i+1 + j = j+1 + 50 continue +c the knots in the y-direction. + 60 mk1 = my-ky1 + if(mk1.eq.0) go to 120 + k3 = ky/2 + i = ky1+1 + j = k3+2 + if(k3*2.eq.ky) go to 80 + do 70 l=1,mk1 + ty(i) = y(j) + i = i+1 + j = j+1 + 70 continue + go to 120 + 80 do 90 l=1,mk1 + ty(i) = (y(j)+y(j-1))*half + i = i+1 + j = j+1 + 90 continue + go to 120 +c if s > 0 our initial choice of knots depends on the value of iopt. + 100 if(iopt.eq.0) go to 115 + if(fp0.le.s) go to 115 +c if iopt=1 and fp0 > s we start computing the least- squares spline +c according to the set of knots found at the last call of the routine. +c we determine the number of grid coordinates x(i) inside each knot +c interval (tx(l),tx(l+1)). + l = kx2 + j = 1 + nrdatx(1) = 0 + mpm = mx-1 + do 105 i=2,mpm + nrdatx(j) = nrdatx(j)+1 + if(x(i).lt.tx(l)) go to 105 + nrdatx(j) = nrdatx(j)-1 + l = l+1 + j = j+1 + nrdatx(j) = 0 + 105 continue +c we determine the number of grid coordinates y(i) inside each knot +c interval (ty(l),ty(l+1)). + l = ky2 + j = 1 + nrdaty(1) = 0 + mpm = my-1 + do 110 i=2,mpm + nrdaty(j) = nrdaty(j)+1 + if(y(i).lt.ty(l)) go to 110 + nrdaty(j) = nrdaty(j)-1 + l = l+1 + j = j+1 + nrdaty(j) = 0 + 110 continue + go to 120 +c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +c polynomial of degree kx in x and ky in y (which is a spline without +c interior knots). + 115 nx = nminx + ny = nminy + nrdatx(1) = mx-2 + nrdaty(1) = my-2 + lastdi = 0 + nplusx = 0 + nplusy = 0 + fp0 = 0. + fpold = 0. + reducx = 0. + reducy = 0. + 120 mpm = mx+my + ifsx = 0 + ifsy = 0 + ifbx = 0 + ifby = 0 + p = -one +c main loop for the different sets of knots.mpm=mx+my is a save upper +c bound for the number of trials. + do 250 iter=1,mpm + if(nx.eq.nminx .and. ny.eq.nminy) ier = -2 +c find nrintx (nrinty) which is the number of knot intervals in the +c x-direction (y-direction). + nrintx = nx-nminx+1 + nrinty = ny-nminy+1 +c find ncof, the number of b-spline coefficients for the current set +c of knots. + nk1x = nx-kx1 + nk1y = ny-ky1 + ncof = nk1x*nk1y +c find the position of the additional knots which are needed for the +c b-spline representation of s(x,y). + i = nx + do 130 j=1,kx1 + tx(j) = xb + tx(i) = xe + i = i-1 + 130 continue + i = ny + do 140 j=1,ky1 + ty(j) = yb + ty(i) = ye + i = i-1 + 140 continue +c find the least-squares spline sinf(x,y) and calculate for each knot +c interval tx(j+kx)<=x<=tx(j+kx+1) (ty(j+ky)<=y<=ty(j+ky+1)) the sum +c of squared residuals fpintx(j),j=1,2,...,nx-2*kx-1 (fpinty(j),j=1,2, +c ...,ny-2*ky-1) for the data points having their absciss (ordinate)- +c value belonging to that interval. +c fp gives the total sum of squared residuals. + call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty, + * ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx), + * wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby), + * nrx,nry) + if(ier.eq.(-2)) fp0 = fp +c test whether the least-squares spline is an acceptable solution. + if(iopt.lt.0) go to 440 + fpms = fp-s + if(abs(fpms) .lt. acc) go to 440 +c if f(p=inf) < s, we accept the choice of knots. + if(fpms.lt.0.) go to 300 +c if nx=nmaxx and ny=nmaxy, sinf(x,y) is an interpolating spline. + if(nx.eq.nmaxx .and. ny.eq.nmaxy) go to 430 +c increase the number of knots. +c if nx=nxe and ny=nye we cannot further increase the number of knots +c because of the storage capacity limitation. + if(nx.eq.nxe .and. ny.eq.nye) go to 420 + ier = 0 +c adjust the parameter reducx or reducy according to the direction +c in which the last added knots were located. + if (lastdi.lt.0) go to 150 + if (lastdi.eq.0) go to 170 + go to 160 + 150 reducx = fpold-fp + go to 170 + 160 reducy = fpold-fp +c store the sum of squared residuals for the current set of knots. + 170 fpold = fp +c find nplx, the number of knots we should add in the x-direction. + nplx = 1 + if(nx.eq.nminx) go to 180 + npl1 = nplusx*2 + rn = nplusx + if(reducx.gt.acc) npl1 = rn*fpms/reducx + nplx = min0(nplusx*2,max0(npl1,nplusx/2,1)) +c find nply, the number of knots we should add in the y-direction. + 180 nply = 1 + if(ny.eq.nminy) go to 190 + npl1 = nplusy*2 + rn = nplusy + if(reducy.gt.acc) npl1 = rn*fpms/reducy + nply = min0(nplusy*2,max0(npl1,nplusy/2,1)) + 190 if (nplx.lt.nply) go to 210 + if (nplx.eq.nply) go to 200 + go to 230 + 200 if(lastdi.lt.0) go to 230 + 210 if(nx.eq.nxe) go to 230 +c addition in the x-direction. + lastdi = -1 + nplusx = nplx + ifsx = 0 + do 220 l=1,nplusx +c add a new knot in the x-direction + call fpknot(x,mx,tx,nx,fpintx,nrdatx,nrintx,nxest,1) +c test whether we cannot further increase the number of knots in the +c x-direction. + if(nx.eq.nxe) go to 250 + 220 continue + go to 250 + 230 if(ny.eq.nye) go to 210 +c addition in the y-direction. + lastdi = 1 + nplusy = nply + ifsy = 0 + do 240 l=1,nplusy +c add a new knot in the y-direction. + call fpknot(y,my,ty,ny,fpinty,nrdaty,nrinty,nyest,1) +c test whether we cannot further increase the number of knots in the +c y-direction. + if(ny.eq.nye) go to 250 + 240 continue +c restart the computations with the new set of knots. + 250 continue +c test whether the least-squares polynomial is a solution of our +c approximation problem. + 300 if(ier.eq.(-2)) go to 440 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline sp(x,y) c +c ***************************************************** c +c we have determined the number of knots and their position. we now c +c compute the b-spline coefficients of the smoothing spline sp(x,y). c +c this smoothing spline varies with the parameter p in such a way thatc +c f(p) = sumi=1,mx(sumj=1,my((z(i,j)-sp(x(i),y(j)))**2) c +c is a continuous, strictly decreasing function of p. moreover the c +c least-squares polynomial corresponds to p=0 and the least-squares c +c spline to p=infinity. iteratively we then have to determine the c +c positive value of p such that f(p)=s. the process which is proposed c +c here makes use of rational interpolation. f(p) is approximated by a c +c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c +c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c +c are used to calculate the new value of p such that r(p)=s. c +c convergence is guaranteed by taking f1 > 0 and f3 < 0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c initial value for p. + p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + p = one + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p)=s. + do 350 iter = 1,maxit +c find the smoothing spline sp(x,y) and the corresponding sum of +c squared residuals fp. + call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty, + * ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx), + * wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby), + * nrx,nry) +c test whether the approximation sp(x,y) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c test whether the maximum allowable number of iterations has been +c reached. + if(iter.eq.maxit) go to 400 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 320 + if((f2-f3).gt.acc) go to 310 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 + p2*con1 + go to 350 + 310 if(f2.lt.0.) ich3 = 1 + 320 if(ich1.ne.0) go to 340 + if((f1-f2).gt.acc) go to 330 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 350 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 350 +c test whether the iteration process proceeds as theoretically +c expected. + 330 if(f2.gt.0.) ich1 = 1 + 340 if(f2.ge.f1 .or. f2.le.f3) go to 410 +c find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 350 continue +c error codes and messages. + 400 ier = 3 + go to 440 + 410 ier = 2 + go to 440 + 420 ier = 1 + go to 440 + 430 ier = -1 + fp = 0. + 440 return + end + diff --git a/fitpack/fprota.f b/fitpack/fprota.f new file mode 100644 index 0000000..bae9d41 --- /dev/null +++ b/fitpack/fprota.f @@ -0,0 +1,14 @@ + recursive subroutine fprota(cos,sin,a,b) +c subroutine fprota applies a givens rotation to a and b. +c .. +c ..scalar arguments.. + real*8 cos,sin,a,b +c ..local scalars.. + real*8 stor1,stor2 +c .. + stor1 = a + stor2 = b + b = cos*stor2+sin*stor1 + a = cos*stor1-sin*stor2 + return + end diff --git a/fitpack/fprppo.f b/fitpack/fprppo.f new file mode 100644 index 0000000..bc91d6c --- /dev/null +++ b/fitpack/fprppo.f @@ -0,0 +1,62 @@ + recursive subroutine fprppo(nu,nv,if1,if2,cosi,ratio,c,f,ncoff) + implicit none +c given the coefficients of a constrained bicubic spline, as determined +c in subroutine fppola, subroutine fprppo calculates the coefficients +c in the standard b-spline representation of bicubic splines. +c .. +c ..scalar arguments.. + real*8 ratio + integer nu,nv,if1,if2,ncoff +c ..array arguments + real*8 c(ncoff),f(ncoff),cosi(5,nv) +c ..local scalars.. + integer i,iopt,ii,j,k,l,nu4,nvv +c .. + nu4 = nu-4 + nvv = nv-7 + iopt = if1+1 + do 10 i=1,ncoff + f(i) = 0. + 10 continue + i = 0 + do 120 l=1,nu4 + ii = i + if(l.gt.iopt) go to 80 + go to (20,40,60),l + 20 do 30 k=1,nvv + i = i+1 + f(i) = c(1) + 30 continue + j = 1 + go to 100 + 40 do 50 k=1,nvv + i = i+1 + f(i) = c(1)+c(2)*cosi(1,k)+c(3)*cosi(2,k) + 50 continue + j = 3 + go to 100 + 60 do 70 k=1,nvv + i = i+1 + f(i) = c(1)+ratio*(c(2)*cosi(1,k)+c(3)*cosi(2,k))+ + * c(4)*cosi(3,k)+c(5)*cosi(4,k)+c(6)*cosi(5,k) + 70 continue + j = 6 + go to 100 + 80 if(l.eq.nu4 .and. if2.ne.0) go to 120 + do 90 k=1,nvv + i = i+1 + j = j+1 + f(i) = c(j) + 90 continue + 100 do 110 k=1,3 + ii = ii+1 + i = i+1 + f(i) = f(ii) + 110 continue + 120 continue + do 130 i=1,ncoff + c(i) = f(i) + 130 continue + return + end + diff --git a/fitpack/fprpsp.f b/fitpack/fprpsp.f new file mode 100644 index 0000000..63a6750 --- /dev/null +++ b/fitpack/fprpsp.f @@ -0,0 +1,56 @@ + recursive subroutine fprpsp(nt,np,co,si,c,f,ncoff) + implicit none +c given the coefficients of a spherical spline function, subroutine +c fprpsp calculates the coefficients in the standard b-spline re- +c presentation of this bicubic spline. +c .. +c ..scalar arguments + integer nt,np,ncoff +c ..array arguments + real*8 co(np),si(np),c(ncoff),f(ncoff) +c ..local scalars + real*8 cn,c1,c2,c3 + integer i,ii,j,k,l,ncof,npp,np4,nt4 +c .. + nt4 = nt-4 + np4 = np-4 + npp = np4-3 + ncof = 6+npp*(nt4-4) + c1 = c(1) + cn = c(ncof) + j = ncoff + do 10 i=1,np4 + f(i) = c1 + f(j) = cn + j = j-1 + 10 continue + i = np4 + j=1 + do 70 l=3,nt4 + ii = i + if(l.eq.3 .or. l.eq.nt4) go to 30 + do 20 k=1,npp + i = i+1 + j = j+1 + f(i) = c(j) + 20 continue + go to 50 + 30 if(l.eq.nt4) c1 = cn + c2 = c(j+1) + c3 = c(j+2) + j = j+2 + do 40 k=1,npp + i = i+1 + f(i) = c1+c2*co(k)+c3*si(k) + 40 continue + 50 do 60 k=1,3 + ii = ii+1 + i = i+1 + f(i) = f(ii) + 60 continue + 70 continue + do 80 i=1,ncoff + c(i) = f(i) + 80 continue + return + end diff --git a/fitpack/fpseno.f b/fitpack/fpseno.f new file mode 100644 index 0000000..aace2f9 --- /dev/null +++ b/fitpack/fpseno.f @@ -0,0 +1,36 @@ + recursive subroutine fpseno(maxtr,up,left,right,info,merk, + * ibind,nbind) + implicit none +c subroutine fpseno fetches a branch of a triply linked tree the +c information of which is kept in the arrays up,left,right and info. +c the branch has a specified length nbind and is determined by the +c parameter merk which points to its terminal node. the information +c field of the nodes of this branch is stored in the array ibind. on +c exit merk points to a new branch of length nbind or takes the value +c 1 if no such branch was found. +c .. +c ..scalar arguments.. + integer maxtr,merk,nbind +c ..array arguments.. + integer up(maxtr),left(maxtr),right(maxtr),info(maxtr), + * ibind(nbind) +c ..scalar arguments.. + integer i,j,k +c .. + k = merk + j = nbind + do 10 i=1,nbind + ibind(j) = info(k) + k = up(k) + j = j-1 + 10 continue + 20 k = right(merk) + if(k.ne.0) go to 30 + merk = up(merk) + if (merk.le.1) go to 40 + go to 20 + 30 merk = k + k = left(merk) + if(k.ne.0) go to 30 + 40 return + end diff --git a/fitpack/fpspgr.f b/fitpack/fpspgr.f new file mode 100644 index 0000000..122828e --- /dev/null +++ b/fitpack/fpspgr.f @@ -0,0 +1,440 @@ + recursive subroutine fpspgr(iopt,ider,u,mu,v,mv,r,mr,r0,r1,s, + * nuest,nvest,tol,maxit,nc,nu,tu,nv,tv,c,fp,fp0,fpold,reducu, + * reducv,fpintu,fpintv,dr,step,lastdi,nplusu,nplusv,lastu0, + * lastu1,nru,nrv,nrdatu,nrdatv,wrk,lwrk,ier) + implicit none +c .. +c ..scalar arguments.. + integer mu,mv,mr,nuest,nvest,maxit,nc,nu,nv,lastdi,nplusu,nplusv, + * lastu0,lastu1,lwrk,ier + real*8 r0,r1,s,tol,fp,fp0,fpold,reducu,reducv +c ..array arguments.. + integer iopt(3),ider(4),nrdatu(nuest),nrdatv(nvest),nru(mu), + * nrv(mv) + real*8 u(mu),v(mv),r(mr),tu(nuest),tv(nvest),c(nc),fpintu(nuest), + * fpintv(nvest),dr(6),wrk(lwrk),step(2) +c ..local scalars.. + real*8 acc,fpms,f1,f2,f3,p,per,pi,p1,p2,p3,vb,ve,rmax,rmin,rn,one, + * + * con1,con4,con9 + integer i,ich1,ich3,ifbu,ifbv,ifsu,ifsv,istart,iter,i1,i2,j,ju, + * ktu,l,l1,l2,l3,l4,mpm,mumin,mu0,mu1,nn,nplu,nplv,npl1,nrintu, + * nrintv,nue,numax,nve,nvmax +c ..local arrays.. + integer idd(4) + real*8 drr(6) +c ..function references.. + real*8 abs,datan2,fprati + integer max0,min0 +c ..subroutine references.. +c fpknot,fpopsp +c .. +c set constants + one = 1d0 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 +c initialization + ifsu = 0 + ifsv = 0 + ifbu = 0 + ifbv = 0 + p = -one + mumin = 4 + if(ider(1).ge.0) mumin = mumin-1 + if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1 + if(ider(3).ge.0) mumin = mumin-1 + if(iopt(3).eq.1 .and. ider(4).eq.1) mumin = mumin-1 + if(mumin.eq.0) mumin = 1 + pi = datan2(0d0,-one) + per = pi+pi + vb = v(1) + ve = vb+per +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(u,v) c +c and the corresponding sum of squared residuals fp = f(p=inf). c +c if iopt(1)=-1 sinf(u,v) is the requested approximation. c +c if iopt(1)>=0 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 s=0 we have spline interpolation; in that case the number of c +c knots in the u-direction equals nu=numax=mu+6+iopt(2)+iopt(3) c +c and in the v-direction nv=nvmax=mv+7. c +c if s>0 and c +c iopt(1)=0 we first compute the least-squares polynomial,i.e. a c +c spline without interior knots : nu=8 ; nv=8. c +c iopt(1)=1 we start with the set of knots found at the last call c +c of the routine, except for the case that s > fp0; then we c +c compute the least-squares polynomial directly. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + if(iopt(1).lt.0) go to 120 +c acc denotes the absolute tolerance for the root of f(p)=s. + acc = tol*s +c numax and nvmax denote the number of knots needed for interpolation. + numax = mu+6+iopt(2)+iopt(3) + nvmax = mv+7 + nue = min0(numax,nuest) + nve = min0(nvmax,nvest) + if(s.gt.0.) go to 100 +c if s = 0, s(u,v) is an interpolating spline. + nu = numax + nv = nvmax +c test whether the required storage space exceeds the available one. + if(nu.gt.nuest .or. nv.gt.nvest) go to 420 +c find the position of the knots in the v-direction. + do 10 l=1,mv + tv(l+3) = v(l) + 10 continue + tv(mv+4) = ve + l1 = mv-2 + l2 = mv+5 + do 20 i=1,3 + tv(i) = v(l1)-per + tv(l2) = v(i+1)+per + l1 = l1+1 + l2 = l2+1 + 20 continue +c if not all the derivative values g(i,j) are given, we will first +c estimate these values by computing a least-squares spline + idd(1) = ider(1) + if(idd(1).eq.0) idd(1) = 1 + if(idd(1).gt.0) dr(1) = r0 + idd(2) = ider(2) + idd(3) = ider(3) + if(idd(3).eq.0) idd(3) = 1 + if(idd(3).gt.0) dr(4) = r1 + idd(4) = ider(4) + if(ider(1).lt.0 .or. ider(3).lt.0) go to 30 + if(iopt(2).ne.0 .and. ider(2).eq.0) go to 30 + if(iopt(3).eq.0 .or. ider(4).ne.0) go to 70 +c we set up the knots in the u-direction for computing the least-squares +c spline. + 30 i1 = 3 + i2 = mu-2 + nu = 4 + do 40 i=1,mu + if(i1.gt.i2) go to 50 + nu = nu+1 + tu(nu) = u(i1) + i1 = i1+2 + 40 continue + 50 do 60 i=1,4 + tu(i) = 0. + nu = nu+1 + tu(nu) = pi + 60 continue +c we compute the least-squares spline for estimating the derivatives. + call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,iopt,idd, + * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, + * wrk,lwrk) + ifsu = 0 +c if all the derivatives at the origin are known, we compute the +c interpolating spline. +c we set up the knots in the u-direction, needed for interpolation. + 70 nn = numax-8 + if(nn.eq.0) go to 95 + ju = 2-iopt(2) + do 80 l=1,nn + tu(l+4) = u(ju) + ju = ju+1 + 80 continue + nu = numax + l = nu + do 90 i=1,4 + tu(i) = 0. + tu(l) = pi + l = l-1 + 90 continue +c we compute the interpolating spline. + 95 call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,iopt,idd, + * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, + * wrk,lwrk) + go to 430 +c if s>0 our initial choice of knots depends on the value of iopt(1). + 100 ier = 0 + if(iopt(1).eq.0) go to 115 + step(1) = -step(1) + step(2) = -step(2) + if(fp0.le.s) go to 115 +c if iopt(1)=1 and fp0 > s we start computing the least-squares spline +c according to the set of knots found at the last call of the routine. +c we determine the number of grid coordinates u(i) inside each knot +c interval (tu(l),tu(l+1)). + l = 5 + j = 1 + nrdatu(1) = 0 + mu0 = 2-iopt(2) + mu1 = mu-1+iopt(3) + do 105 i=mu0,mu1 + nrdatu(j) = nrdatu(j)+1 + if(u(i).lt.tu(l)) go to 105 + nrdatu(j) = nrdatu(j)-1 + l = l+1 + j = j+1 + nrdatu(j) = 0 + 105 continue +c we determine the number of grid coordinates v(i) inside each knot +c interval (tv(l),tv(l+1)). + l = 5 + j = 1 + nrdatv(1) = 0 + do 110 i=2,mv + nrdatv(j) = nrdatv(j)+1 + if(v(i).lt.tv(l)) go to 110 + nrdatv(j) = nrdatv(j)-1 + l = l+1 + j = j+1 + nrdatv(j) = 0 + 110 continue + idd(1) = ider(1) + idd(2) = ider(2) + idd(3) = ider(3) + idd(4) = ider(4) + go to 120 +c if iopt(1)=0 or iopt(1)=1 and s >= fp0,we start computing the least- +c squares polynomial (which is a spline without interior knots). + 115 ier = -2 + idd(1) = ider(1) + idd(2) = 1 + idd(3) = ider(3) + idd(4) = 1 + nu = 8 + nv = 8 + nrdatu(1) = mu-2+iopt(2)+iopt(3) + nrdatv(1) = mv-1 + lastdi = 0 + nplusu = 0 + nplusv = 0 + fp0 = 0. + fpold = 0. + reducu = 0. + reducv = 0. +c main loop for the different sets of knots.mpm=mu+mv is a save upper +c bound for the number of trials. + 120 mpm = mu+mv + do 270 iter=1,mpm +c find nrintu (nrintv) which is the number of knot intervals in the +c u-direction (v-direction). + nrintu = nu-7 + nrintv = nv-7 +c find the position of the additional knots which are needed for the +c b-spline representation of s(u,v). + i = nu + do 125 j=1,4 + tu(j) = 0. + tu(i) = pi + i = i-1 + 125 continue + l1 = 4 + l2 = l1 + l3 = nv-3 + l4 = l3 + tv(l2) = vb + tv(l3) = ve + do 130 j=1,3 + l1 = l1+1 + l2 = l2-1 + l3 = l3+1 + l4 = l4-1 + tv(l2) = tv(l4)-per + tv(l3) = tv(l1)+per + 130 continue +c find an estimate of the range of possible values for the optimal +c derivatives at the origin. + ktu = nrdatu(1)+2-iopt(2) + if(ktu.lt.mumin) ktu = mumin + if(ktu.eq.lastu0) go to 140 + rmin = r0 + rmax = r0 + l = mv*ktu + do 135 i=1,l + if(r(i).lt.rmin) rmin = r(i) + if(r(i).gt.rmax) rmax = r(i) + 135 continue + step(1) = rmax-rmin + lastu0 = ktu + 140 ktu = nrdatu(nrintu)+2-iopt(3) + if(ktu.lt.mumin) ktu = mumin + if(ktu.eq.lastu1) go to 150 + rmin = r1 + rmax = r1 + l = mv*ktu + j = mr + do 145 i=1,l + if(r(j).lt.rmin) rmin = r(j) + if(r(j).gt.rmax) rmax = r(j) + j = j-1 + 145 continue + step(2) = rmax-rmin + lastu1 = ktu +c find the least-squares spline sinf(u,v). + 150 call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,iopt, + * idd,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru, + * nrv,wrk,lwrk) + if(step(1).lt.0.) step(1) = -step(1) + if(step(2).lt.0.) step(2) = -step(2) + if(ier.eq.(-2)) fp0 = fp +c test whether the least-squares spline is an acceptable solution. + if(iopt(1).lt.0) go to 440 + fpms = fp-s + if(abs(fpms) .lt. acc) go to 440 +c if f(p=inf) < s, we accept the choice of knots. + if(fpms.lt.0.) go to 300 +c if nu=numax and nv=nvmax, sinf(u,v) is an interpolating spline + if(nu.eq.numax .and. nv.eq.nvmax) go to 430 +c increase the number of knots. +c if nu=nue and nv=nve we cannot further increase the number of knots +c because of the storage capacity limitation. + if(nu.eq.nue .and. nv.eq.nve) go to 420 + if(ider(1).eq.0) fpintu(1) = fpintu(1)+(r0-dr(1))**2 + if(ider(3).eq.0) fpintu(nrintu) = fpintu(nrintu)+(r1-dr(4))**2 + ier = 0 +c adjust the parameter reducu or reducv according to the direction +c in which the last added knots were located. + if (lastdi.lt.0) go to 160 + if (lastdi.eq.0) go to 155 + go to 170 + 155 nplv = 3 + idd(2) = ider(2) + idd(4) = ider(4) + fpold = fp + go to 230 + 160 reducu = fpold-fp + go to 175 + 170 reducv = fpold-fp +c store the sum of squared residuals for the current set of knots. + 175 fpold = fp +c find nplu, the number of knots we should add in the u-direction. + nplu = 1 + if(nu.eq.8) go to 180 + npl1 = nplusu*2 + rn = nplusu + if(reducu.gt.acc) npl1 = rn*fpms/reducu + nplu = min0(nplusu*2,max0(npl1,nplusu/2,1)) +c find nplv, the number of knots we should add in the v-direction. + 180 nplv = 3 + if(nv.eq.8) go to 190 + npl1 = nplusv*2 + rn = nplusv + if(reducv.gt.acc) npl1 = rn*fpms/reducv + nplv = min0(nplusv*2,max0(npl1,nplusv/2,1)) +c test whether we are going to add knots in the u- or v-direction. + 190 if (nplu.lt.nplv) go to 210 + if (nplu.eq.nplv) go to 200 + go to 230 + 200 if(lastdi.lt.0) go to 230 + 210 if(nu.eq.nue) go to 230 +c addition in the u-direction. + lastdi = -1 + nplusu = nplu + ifsu = 0 + istart = 0 + if(iopt(2).eq.0) istart = 1 + do 220 l=1,nplusu +c add a new knot in the u-direction + call fpknot(u,mu,tu,nu,fpintu,nrdatu,nrintu,nuest,istart) +c test whether we cannot further increase the number of knots in the +c u-direction. + if(nu.eq.nue) go to 270 + 220 continue + go to 270 + 230 if(nv.eq.nve) go to 210 +c addition in the v-direction. + lastdi = 1 + nplusv = nplv + ifsv = 0 + do 240 l=1,nplusv +c add a new knot in the v-direction. + call fpknot(v,mv,tv,nv,fpintv,nrdatv,nrintv,nvest,1) +c test whether we cannot further increase the number of knots in the +c v-direction. + if(nv.eq.nve) go to 270 + 240 continue +c restart the computations with the new set of knots. + 270 continue +c test whether the least-squares polynomial is a solution of our +c approximation problem. + 300 if(ier.eq.(-2)) go to 440 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline sp(u,v) c +c ***************************************************** c +c we have determined the number of knots and their position. we now c +c compute the b-spline coefficients of the smoothing spline sp(u,v). c +c this smoothing spline depends on the parameter p in such a way that c +c f(p) = sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2) c +c is a continuous, strictly decreasing function of p. moreover the c +c least-squares polynomial corresponds to p=0 and the least-squares c +c spline to p=infinity. then iteratively we have to determine the c +c positive value of p such that f(p)=s. the process which is proposed c +c here makes use of rational interpolation. f(p) is approximated by a c +c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c +c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c +c are used to calculate the new value of p such that r(p)=s. c +c convergence is guaranteed by taking f1 > 0 and f3 < 0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c initial value for p. + p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + p = one + do 305 i=1,6 + drr(i) = dr(i) + 305 continue + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p)=s. + do 350 iter = 1,maxit +c find the smoothing spline sp(u,v) and the corresponding sum f(p). + call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,drr,iopt, + * idd,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru, + * nrv,wrk,lwrk) +c test whether the approximation sp(u,v) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c test whether the maximum allowable number of iterations has been +c reached. + if(iter.eq.maxit) go to 400 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 320 + if((f2-f3).gt.acc) go to 310 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 + p2*con1 + go to 350 + 310 if(f2.lt.0.) ich3 = 1 + 320 if(ich1.ne.0) go to 340 + if((f1-f2).gt.acc) go to 330 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 350 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 350 +c test whether the iteration process proceeds as theoretically +c expected. + 330 if(f2.gt.0.) ich1 = 1 + 340 if(f2.ge.f1 .or. f2.le.f3) go to 410 +c find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 350 continue +c error codes and messages. + 400 ier = 3 + go to 440 + 410 ier = 2 + go to 440 + 420 ier = 1 + go to 440 + 430 ier = -1 + fp = 0. + 440 return + end diff --git a/fitpack/fpsphe.f b/fitpack/fpsphe.f new file mode 100644 index 0000000..04858b0 --- /dev/null +++ b/fitpack/fpsphe.f @@ -0,0 +1,765 @@ + recursive subroutine fpsphe(iopt,m,teta,phi,r,w,s,ntest,npest, + * eta,tol,maxit, + * ib1,ib3,nc,ncc,intest,nrest,nt,tt,np,tp,c,fp,sup,fpint,coord,f, + * ff,row,coco,cosi,a,q,bt,bp,spt,spp,h,index,nummer,wrk,lwrk,ier) + implicit none +c .. +c ..scalar arguments.. + integer iopt,m,ntest,npest,maxit,ib1,ib3,nc,ncc,intest,nrest, + * nt,np,lwrk,ier + real*8 s,eta,tol,fp,sup +c ..array arguments.. + real*8 teta(m),phi(m),r(m),w(m),tt(ntest),tp(npest),c(nc), + * fpint(intest),coord(intest),f(ncc),ff(nc),row(npest),coco(npest), + * + * cosi(npest),a(ncc,ib1),q(ncc,ib3),bt(ntest,5),bp(npest,5), + * spt(m,4),spp(m,4),h(ib3),wrk(lwrk) + integer index(nrest),nummer(m) +c ..local scalars.. + real*8 aa,acc,arg,cn,co,c1,dmax,d1,d2,eps,facc,facs,fac1,fac2,fn, + * fpmax,fpms,f1,f2,f3,hti,htj,p,pi,pinv,piv,pi2,p1,p2,p3,ri,si, + * sigma,sq,store,wi,rn,one,con1,con9,con4,half,ten + integer i,iband,iband1,iband3,iband4,ich1,ich3,ii,ij,il,in,irot, + * iter,i1,i2,i3,j,jlt,jrot,j1,j2,l,la,lf,lh,ll,lp,lt,lwest,l1,l2, + * l3,l4,ncof,ncoff,npp,np4,nreg,nrint,nrr,nr1,ntt,nt4,nt6,num, + * num1,rank +c ..local arrays.. + real*8 ht(4),hp(4) +c ..function references.. + real*8 abs,atan,fprati,sqrt,cos,sin + integer min0 +c ..subroutine references.. +c fpback,fpbspl,fpgivs,fpdisc,fporde,fprank,fprota,fprpsp +c .. +c set constants + one = 0.1e+01 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 + half = 0.5e0 + ten = 0.1e+02 + pi = atan(one)*4 + pi2 = pi+pi + eps = sqrt(eta) + if(iopt.lt.0) go to 70 +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s + if(iopt.eq.0) go to 10 + if(s.lt.sup) then + if (np.lt.11) go to 60 + go to 70 + endif +c if iopt=0 we begin by computing the weighted least-squares polynomial +c of the form +c s(teta,phi) = c1*f1(teta) + cn*fn(teta) +c where f1(teta) and fn(teta) are the cubic polynomials satisfying +c f1(0) = 1, f1(pi) = f1'(0) = f1'(pi) = 0 ; fn(teta) = 1-f1(teta). +c the corresponding weighted sum of squared residuals gives the upper +c bound sup for the smoothing factor s. + 10 sup = 0. + d1 = 0. + d2 = 0. + c1 = 0. + cn = 0. + fac1 = pi*(one + half) + fac2 = (one + one)/pi**3 + aa = 0. + do 40 i=1,m + wi = w(i) + ri = r(i)*wi + arg = teta(i) + fn = fac2*arg*arg*(fac1-arg) + f1 = (one-fn)*wi + fn = fn*wi + if(fn.eq.0.) go to 20 + call fpgivs(fn,d1,co,si) + call fprota(co,si,f1,aa) + call fprota(co,si,ri,cn) + 20 if(f1.eq.0.) go to 30 + call fpgivs(f1,d2,co,si) + call fprota(co,si,ri,c1) + 30 sup = sup+ri*ri + 40 continue + if(d2.ne.0.) c1 = c1/d2 + if(d1.ne.0.) cn = (cn-aa*c1)/d1 +c find the b-spline representation of this least-squares polynomial + nt = 8 + np = 8 + do 50 i=1,4 + c(i) = c1 + c(i+4) = c1 + c(i+8) = cn + c(i+12) = cn + tt(i) = 0. + tt(i+4) = pi + tp(i) = 0. + tp(i+4) = pi2 + 50 continue + fp = sup +c test whether the least-squares polynomial is an acceptable solution + fpms = sup-s + if(fpms.lt.acc) go to 960 +c test whether we cannot further increase the number of knots. + 60 if(npest.lt.11 .or. ntest.lt.9) go to 950 +c find the initial set of interior knots of the spherical spline in +c case iopt = 0. + np = 11 + tp(5) = pi*half + tp(6) = pi + tp(7) = tp(5)+pi + nt = 9 + tt(5) = tp(5) +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 1 : computation of least-squares spherical splines. c +c ******************************************************** c +c if iopt < 0 we compute the least-squares spherical spline according c +c to the given set of knots. c +c if iopt >=0 we compute least-squares spherical splines with increas-c +c ing numbers of knots until the corresponding sum f(p=inf)<=s. c +c the initial set of knots then depends on the value of iopt: c +c if iopt=0 we start with one interior knot in the teta-direction c +c (pi/2) and three in the phi-direction (pi/2,pi,3*pi/2). c +c if iopt>0 we start with the set of knots found at the last call c +c of the routine. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c main loop for the different sets of knots. m is a save upper bound +c for the number of trials. + 70 do 570 iter=1,m +c find the position of the additional knots which are needed for the +c b-spline representation of s(teta,phi). + l1 = 4 + l2 = l1 + l3 = np-3 + l4 = l3 + tp(l2) = 0. + tp(l3) = pi2 + do 80 i=1,3 + l1 = l1+1 + l2 = l2-1 + l3 = l3+1 + l4 = l4-1 + tp(l2) = tp(l4)-pi2 + tp(l3) = tp(l1)+pi2 + 80 continue + l = nt + do 90 i=1,4 + tt(i) = 0. + tt(l) = pi + l = l-1 + 90 continue +c find nrint, the total number of knot intervals and nreg, the number +c of panels in which the approximation domain is subdivided by the +c intersection of knots. + ntt = nt-7 + npp = np-7 + nrr = npp/2 + nr1 = nrr+1 + nrint = ntt+npp + nreg = ntt*npp +c arrange the data points according to the panel they belong to. + call fporde(teta,phi,m,3,3,tt,nt,tp,np,nummer,index,nreg) +c find the b-spline coefficients coco and cosi of the cubic spline +c approximations sc(phi) and ss(phi) for cos(phi) and sin(phi). + do 100 i=1,npp + coco(i) = 0. + cosi(i) = 0. + do 100 j=1,npp + a(i,j) = 0. + 100 continue +c the coefficients coco and cosi are obtained from the conditions +c sc(tp(i))=cos(tp(i)),resp. ss(tp(i))=sin(tp(i)),i=4,5,...np-4. + do 150 i=1,npp + l2 = i+3 + arg = tp(l2) + call fpbspl(tp,np,3,arg,l2,hp) + do 110 j=1,npp + row(j) = 0. + 110 continue + ll = i + do 120 j=1,3 + if(ll.gt.npp) ll= 1 + row(ll) = row(ll)+hp(j) + ll = ll+1 + 120 continue + facc = cos(arg) + facs = sin(arg) + do 140 j=1,npp + piv = row(j) + if(piv.eq.0.) go to 140 + call fpgivs(piv,a(j,1),co,si) + call fprota(co,si,facc,coco(j)) + call fprota(co,si,facs,cosi(j)) + if(j.eq.npp) go to 150 + j1 = j+1 + i2 = 1 + do 130 l=j1,npp + i2 = i2+1 + call fprota(co,si,row(l),a(j,i2)) + 130 continue + 140 continue + 150 continue + call fpback(a,coco,npp,npp,coco,ncc) + call fpback(a,cosi,npp,npp,cosi,ncc) +c find ncof, the dimension of the spherical spline and ncoff, the +c number of coefficients in the standard b-spline representation. + nt4 = nt-4 + np4 = np-4 + ncoff = nt4*np4 + ncof = 6+npp*(ntt-1) +c find the bandwidth of the observation matrix a. + iband = 4*npp + if(ntt.eq.4) iband = 3*(npp+1) + if(ntt.lt.4) iband = ncof + iband1 = iband-1 +c initialize the observation matrix a. + do 160 i=1,ncof + f(i) = 0. + do 160 j=1,iband + a(i,j) = 0. + 160 continue +c initialize the sum of squared residuals. + fp = 0. +c fetch the data points in the new order. main loop for the +c different panels. + do 340 num=1,nreg +c fix certain constants for the current panel; jrot records the column +c number of the first non-zero element in a row of the observation +c matrix according to a data point of the panel. + num1 = num-1 + lt = num1/npp + l1 = lt+4 + lp = num1-lt*npp+1 + l2 = lp+3 + lt = lt+1 + jrot = 0 + if(lt.gt.2) jrot = 3+(lt-3)*npp +c test whether there are still data points in the current panel. + in = index(num) + 170 if(in.eq.0) go to 340 +c fetch a new data point. + wi = w(in) + ri = r(in)*wi +c evaluate for the teta-direction, the 4 non-zero b-splines at teta(in) + call fpbspl(tt,nt,3,teta(in),l1,ht) +c evaluate for the phi-direction, the 4 non-zero b-splines at phi(in) + call fpbspl(tp,np,3,phi(in),l2,hp) +c store the value of these b-splines in spt and spp resp. + do 180 i=1,4 + spp(in,i) = hp(i) + spt(in,i) = ht(i) + 180 continue +c initialize the new row of observation matrix. + do 190 i=1,iband + h(i) = 0. + 190 continue +c calculate the non-zero elements of the new row by making the cross +c products of the non-zero b-splines in teta- and phi-direction and +c by taking into account the conditions of the spherical splines. + do 200 i=1,npp + row(i) = 0. + 200 continue +c take into account the condition (3) of the spherical splines. + ll = lp + do 210 i=1,4 + if(ll.gt.npp) ll=1 + row(ll) = row(ll)+hp(i) + ll = ll+1 + 210 continue +c take into account the other conditions of the spherical splines. + if(lt.gt.2 .and. lt.lt.(ntt-1)) go to 230 + facc = 0. + facs = 0. + do 220 i=1,npp + facc = facc+row(i)*coco(i) + facs = facs+row(i)*cosi(i) + 220 continue +c fill in the non-zero elements of the new row. + 230 j1 = 0 + do 280 j =1,4 + jlt = j+lt + htj = ht(j) + if(jlt.gt.2 .and. jlt.le.nt4) go to 240 + j1 = j1+1 + h(j1) = h(j1)+htj + go to 280 + 240 if(jlt.eq.3 .or. jlt.eq.nt4) go to 260 + do 250 i=1,npp + j1 = j1+1 + h(j1) = row(i)*htj + 250 continue + go to 280 + 260 if(jlt.eq.3) go to 270 + h(j1+1) = facc*htj + h(j1+2) = facs*htj + h(j1+3) = htj + j1 = j1+2 + go to 280 + 270 h(1) = h(1)+htj + h(2) = facc*htj + h(3) = facs*htj + j1 = 3 + 280 continue + do 290 i=1,iband + h(i) = h(i)*wi + 290 continue +c rotate the row into triangle by givens transformations. + irot = jrot + do 310 i=1,iband + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 310 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(irot,1),co,si) +c apply that transformation to the right hand side. + call fprota(co,si,ri,f(irot)) + if(i.eq.iband) go to 320 +c apply that transformation to the left hand side. + i2 = 1 + i3 = i+1 + do 300 j=i3,iband + i2 = i2+1 + call fprota(co,si,h(j),a(irot,i2)) + 300 continue + 310 continue +c add the contribution of the row to the sum of squares of residual +c right hand sides. + 320 fp = fp+ri**2 +c find the number of the next data point in the panel. + in = nummer(in) + go to 170 + 340 continue +c find dmax, the maximum value for the diagonal elements in the reduced +c triangle. + dmax = 0. + do 350 i=1,ncof + if(a(i,1).le.dmax) go to 350 + dmax = a(i,1) + 350 continue +c check whether the observation matrix is rank deficient. + sigma = eps*dmax + do 360 i=1,ncof + if(a(i,1).le.sigma) go to 370 + 360 continue +c backward substitution in case of full rank. + call fpback(a,f,ncof,iband,c,ncc) + rank = ncof + do 365 i=1,ncof + q(i,1) = a(i,1)/dmax + 365 continue + go to 390 +c in case of rank deficiency, find the minimum norm solution. + 370 lwest = ncof*iband+ncof+iband + if(lwrk.lt.lwest) go to 925 + lf = 1 + lh = lf+ncof + la = lh+iband + do 380 i=1,ncof + ff(i) = f(i) + do 380 j=1,iband + q(i,j) = a(i,j) + 380 continue + call fprank(q,ff,ncof,iband,ncc,sigma,c,sq,rank,wrk(la), + * wrk(lf),wrk(lh)) + do 385 i=1,ncof + q(i,1) = q(i,1)/dmax + 385 continue +c add to the sum of squared residuals, the contribution of reducing +c the rank. + fp = fp+sq +c find the coefficients in the standard b-spline representation of +c the spherical spline. + 390 call fprpsp(nt,np,coco,cosi,c,ff,ncoff) +c test whether the least-squares spline is an acceptable solution. + if(iopt.lt.0) then + if (fp.le.0) go to 970 + go to 980 + endif + fpms = fp-s + if(abs(fpms).le.acc) then + if (fp.le.0) go to 970 + go to 980 + endif +c if f(p=inf) < s, accept the choice of knots. + if(fpms.lt.0.) go to 580 +c test whether we cannot further increase the number of knots. + if(ncof.gt.m) go to 935 +c search where to add a new knot. +c find for each interval the sum of squared residuals fpint for the +c data points having the coordinate belonging to that knot interval. +c calculate also coord which is the same sum, weighted by the position +c of the data points considered. + do 450 i=1,nrint + fpint(i) = 0. + coord(i) = 0. + 450 continue + do 490 num=1,nreg + num1 = num-1 + lt = num1/npp + l1 = lt+1 + lp = num1-lt*npp + l2 = lp+1+ntt + jrot = lt*np4+lp + in = index(num) + 460 if(in.eq.0) go to 490 + store = 0. + i1 = jrot + do 480 i=1,4 + hti = spt(in,i) + j1 = i1 + do 470 j=1,4 + j1 = j1+1 + store = store+hti*spp(in,j)*c(j1) + 470 continue + i1 = i1+np4 + 480 continue + store = (w(in)*(r(in)-store))**2 + fpint(l1) = fpint(l1)+store + coord(l1) = coord(l1)+store*teta(in) + fpint(l2) = fpint(l2)+store + coord(l2) = coord(l2)+store*phi(in) + in = nummer(in) + go to 460 + 490 continue +c find the interval for which fpint is maximal on the condition that +c there still can be added a knot. + l1 = 1 + l2 = nrint + if(ntest.lt.nt+1) l1=ntt+1 + if(npest.lt.np+2) l2=ntt +c test whether we cannot further increase the number of knots. + if(l1.gt.l2) go to 950 + 500 fpmax = 0. + l = 0 + do 510 i=l1,l2 + if(fpmax.ge.fpint(i)) go to 510 + l = i + fpmax = fpint(i) + 510 continue + if(l.eq.0) go to 930 +c calculate the position of the new knot. + arg = coord(l)/fpint(l) +c test in what direction the new knot is going to be added. + if(l.gt.ntt) go to 530 +c addition in the teta-direction + l4 = l+4 + fpint(l) = 0. + fac1 = tt(l4)-arg + fac2 = arg-tt(l4-1) + if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500 + j = nt + do 520 i=l4,nt + tt(j+1) = tt(j) + j = j-1 + 520 continue + tt(l4) = arg + nt = nt+1 + go to 570 +c addition in the phi-direction + 530 l4 = l+4-ntt + if(arg.lt.pi) go to 540 + arg = arg-pi + l4 = l4-nrr + 540 fpint(l) = 0. + fac1 = tp(l4)-arg + fac2 = arg-tp(l4-1) + if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500 + ll = nrr+4 + j = ll + do 550 i=l4,ll + tp(j+1) = tp(j) + j = j-1 + 550 continue + tp(l4) = arg + np = np+2 + nrr = nrr+1 + do 560 i=5,ll + j = i+nrr + tp(j) = tp(i)+pi + 560 continue +c restart the computations with the new set of knots. + 570 continue +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spherical spline. c +c ******************************************************** c +c we have determined the number of knots and their position. we now c +c compute the coefficients of the smoothing spline sp(teta,phi). c +c the observation matrix a is extended by the rows of a matrix, expres-c +c sing that sp(teta,phi) must be a constant function in the variable c +c phi and a cubic polynomial in the variable teta. the corresponding c +c weights of these additional rows are set to 1/(p). iteratively c +c we than have to determine the value of p such that f(p) = sum((w(i)* c +c (r(i)-sp(teta(i),phi(i))))**2) be = s. c +c we already know that the least-squares polynomial corresponds to p=0,c +c and that the least-squares spherical spline corresponds to p=infin. c +c the iteration process makes use of rational interpolation. since f(p)c +c is a convex and strictly decreasing function of p, it can be approx- c +c imated by a rational function of the form r(p) = (u*p+v)/(p+w). c +c three values of p (p1,p2,p3) with corresponding values of f(p) (f1= c +c f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the new value c +c of p such that r(p)=s. convergence is guaranteed by taking f1>0,f3<0.c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c evaluate the discontinuity jumps of the 3-th order derivative of +c the b-splines at the knots tt(l),l=5,...,nt-4. + 580 call fpdisc(tt,nt,5,bt,ntest) +c evaluate the discontinuity jumps of the 3-th order derivative of +c the b-splines at the knots tp(l),l=5,...,np-4. + call fpdisc(tp,np,5,bp,npest) +c initial value for p. + p1 = 0. + f1 = sup-s + p3 = -one + f3 = fpms + p = 0. + do 585 i=1,ncof + p = p+a(i,1) + 585 continue + rn = ncof + p = rn/p +c find the bandwidth of the extended observation matrix. + iband4 = iband+3 + if(ntt.le.4) iband4 = ncof + iband3 = iband4 -1 + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p)=s. + do 920 iter=1,maxit + pinv = one/p +c store the triangularized observation matrix into q. + do 600 i=1,ncof + ff(i) = f(i) + do 590 j=1,iband4 + q(i,j) = 0. + 590 continue + do 600 j=1,iband + q(i,j) = a(i,j) + 600 continue +c extend the observation matrix with the rows of a matrix, expressing +c that for teta=cst. sp(teta,phi) must be a constant function. + nt6 = nt-6 + do 720 i=5,np4 + ii = i-4 + do 610 l=1,npp + row(l) = 0. + 610 continue + ll = ii + do 620 l=1,5 + if(ll.gt.npp) ll=1 + row(ll) = row(ll)+bp(ii,l) + ll = ll+1 + 620 continue + facc = 0. + facs = 0. + do 630 l=1,npp + facc = facc+row(l)*coco(l) + facs = facs+row(l)*cosi(l) + 630 continue + do 720 j=1,nt6 +c initialize the new row. + do 640 l=1,iband + h(l) = 0. + 640 continue +c fill in the non-zero elements of the row. jrot records the column +c number of the first non-zero element in the row. + jrot = 4+(j-2)*npp + if(j.gt.1 .and. j.lt.nt6) go to 650 + h(1) = facc + h(2) = facs + if(j.eq.1) jrot = 2 + go to 670 + 650 do 660 l=1,npp + h(l)=row(l) + 660 continue + 670 do 675 l=1,iband + h(l) = h(l)*pinv + 675 continue + ri = 0. +c rotate the new row into triangle by givens transformations. + do 710 irot=jrot,ncof + piv = h(1) + i2 = min0(iband1,ncof-irot) + if(piv.eq.0.) then + if (i2.le.0) go to 720 + go to 690 + endif +c calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),co,si) +c apply that givens transformation to the right hand side. + call fprota(co,si,ri,ff(irot)) + if(i2.eq.0) go to 720 +c apply that givens transformation to the left hand side. + do 680 l=1,i2 + l1 = l+1 + call fprota(co,si,h(l1),q(irot,l1)) + 680 continue + 690 do 700 l=1,i2 + h(l) = h(l+1) + 700 continue + h(i2+1) = 0. + 710 continue + 720 continue +c extend the observation matrix with the rows of a matrix expressing +c that for phi=cst. sp(teta,phi) must be a cubic polynomial. + do 810 i=5,nt4 + ii = i-4 + do 810 j=1,npp +c initialize the new row + do 730 l=1,iband4 + h(l) = 0. + 730 continue +c fill in the non-zero elements of the row. jrot records the column +c number of the first non-zero element in the row. + j1 = 1 + do 760 l=1,5 + il = ii+l + ij = npp + if(il.ne.3 .and. il.ne.nt4) go to 750 + j1 = j1+3-j + j2 = j1-2 + ij = 0 + if(il.ne.3) go to 740 + j1 = 1 + j2 = 2 + ij = j+2 + 740 h(j2) = bt(ii,l)*coco(j) + h(j2+1) = bt(ii,l)*cosi(j) + 750 h(j1) = h(j1)+bt(ii,l) + j1 = j1+ij + 760 continue + do 765 l=1,iband4 + h(l) = h(l)*pinv + 765 continue + ri = 0. + jrot = 1 + if(ii.gt.2) jrot = 3+j+(ii-3)*npp +c rotate the new row into triangle by givens transformations. + do 800 irot=jrot,ncof + piv = h(1) + i2 = min0(iband3,ncof-irot) + if(piv.eq.0.) then + if (i2.le.0) go to 810 + go to 780 + endif +c calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),co,si) +c apply that givens transformation to the right hand side. + call fprota(co,si,ri,ff(irot)) + if(i2.eq.0) go to 810 +c apply that givens transformation to the left hand side. + do 770 l=1,i2 + l1 = l+1 + call fprota(co,si,h(l1),q(irot,l1)) + 770 continue + 780 do 790 l=1,i2 + h(l) = h(l+1) + 790 continue + h(i2+1) = 0. + 800 continue + 810 continue +c find dmax, the maximum value for the diagonal elements in the +c reduced triangle. + dmax = 0. + do 820 i=1,ncof + if(q(i,1).le.dmax) go to 820 + dmax = q(i,1) + 820 continue +c check whether the matrix is rank deficient. + sigma = eps*dmax + do 830 i=1,ncof + if(q(i,1).le.sigma) go to 840 + 830 continue +c backward substitution in case of full rank. + call fpback(q,ff,ncof,iband4,c,ncc) + rank = ncof + go to 845 +c in case of rank deficiency, find the minimum norm solution. + 840 lwest = ncof*iband4+ncof+iband4 + if(lwrk.lt.lwest) go to 925 + lf = 1 + lh = lf+ncof + la = lh+iband4 + call fprank(q,ff,ncof,iband4,ncc,sigma,c,sq,rank,wrk(la), + * wrk(lf),wrk(lh)) + 845 do 850 i=1,ncof + q(i,1) = q(i,1)/dmax + 850 continue +c find the coefficients in the standard b-spline representation of +c the spherical spline. + call fprpsp(nt,np,coco,cosi,c,ff,ncoff) +c compute f(p). + fp = 0. + do 890 num = 1,nreg + num1 = num-1 + lt = num1/npp + lp = num1-lt*npp + jrot = lt*np4+lp + in = index(num) + 860 if(in.eq.0) go to 890 + store = 0. + i1 = jrot + do 880 i=1,4 + hti = spt(in,i) + j1 = i1 + do 870 j=1,4 + j1 = j1+1 + store = store+hti*spp(in,j)*c(j1) + 870 continue + i1 = i1+np4 + 880 continue + fp = fp+(w(in)*(r(in)-store))**2 + in = nummer(in) + go to 860 + 890 continue +c test whether the approximation sp(teta,phi) is an acceptable solution + fpms = fp-s + if(abs(fpms).le.acc) go to 980 +c test whether the maximum allowable number of iterations has been +c reached. + if(iter.eq.maxit) go to 940 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 900 + if((f2-f3).gt.acc) go to 895 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 + p2*con1 + go to 920 + 895 if(f2.lt.0.) ich3 = 1 + 900 if(ich1.ne.0) go to 910 + if((f1-f2).gt.acc) go to 905 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 920 + if(p.ge.p3) p = p2*con1 +p3*con9 + go to 920 + 905 if(f2.gt.0.) ich1 = 1 +c test whether the iteration process proceeds as theoretically +c expected. + 910 if(f2.ge.f1 .or. f2.le.f3) go to 945 +c find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 920 continue +c error codes and messages. + 925 ier = lwest + go to 990 + 930 ier = 5 + go to 990 + 935 ier = 4 + go to 990 + 940 ier = 3 + go to 990 + 945 ier = 2 + go to 990 + 950 ier = 1 + go to 990 + 960 ier = -2 + go to 990 + 970 ier = -1 + fp = 0. + 980 if(ncof.ne.rank) ier = -rank + 990 return + end diff --git a/fitpack/fpsuev.f b/fitpack/fpsuev.f new file mode 100644 index 0000000..bc88d06 --- /dev/null +++ b/fitpack/fpsuev.f @@ -0,0 +1,82 @@ + recursive subroutine fpsuev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f, + * wu,wv,lu,lv) + implicit none +c ..scalar arguments.. + integer idim,nu,nv,mu,mv +c ..array arguments.. + integer lu(mu),lv(mv) + real*8 tu(nu),tv(nv),c((nu-4)*(nv-4)*idim),u(mu),v(mv), + * f(mu*mv*idim),wu(mu,4),wv(mv,4) +c ..local scalars.. + integer i,i1,j,j1,k,l,l1,l2,l3,m,nuv,nu4,nv4 + real*8 arg,sp,tb,te +c ..local arrays.. + real*8 h(4) +c ..subroutine references.. +c fpbspl +c .. + nu4 = nu-4 + tb = tu(4) + te = tu(nu4+1) + l = 4 + l1 = l+1 + do 40 i=1,mu + arg = u(i) + if(arg.lt.tb) arg = tb + if(arg.gt.te) arg = te + 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 20 + l = l1 + l1 = l+1 + go to 10 + 20 call fpbspl(tu,nu,3,arg,l,h) + lu(i) = l-4 + do 30 j=1,4 + wu(i,j) = h(j) + 30 continue + 40 continue + nv4 = nv-4 + tb = tv(4) + te = tv(nv4+1) + l = 4 + l1 = l+1 + do 80 i=1,mv + arg = v(i) + if(arg.lt.tb) arg = tb + if(arg.gt.te) arg = te + 50 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 60 + l = l1 + l1 = l+1 + go to 50 + 60 call fpbspl(tv,nv,3,arg,l,h) + lv(i) = l-4 + do 70 j=1,4 + wv(i,j) = h(j) + 70 continue + 80 continue + m = 0 + nuv = nu4*nv4 + do 140 k=1,idim + l3 = (k-1)*nuv + do 130 i=1,mu + l = lu(i)*nv4+l3 + do 90 i1=1,4 + h(i1) = wu(i,i1) + 90 continue + do 120 j=1,mv + l1 = l+lv(j) + sp = 0. + do 110 i1=1,4 + l2 = l1 + do 100 j1=1,4 + l2 = l2+1 + sp = sp+c(l2)*h(i1)*wv(j,j1) + 100 continue + l1 = l1+nv4 + 110 continue + m = m+1 + f(m) = sp + 120 continue + 130 continue + 140 continue + return + end diff --git a/fitpack/fpsurf.f b/fitpack/fpsurf.f new file mode 100644 index 0000000..9b532a4 --- /dev/null +++ b/fitpack/fpsurf.f @@ -0,0 +1,681 @@ + recursive subroutine fpsurf(iopt,m,x,y,z,w,xb,xe,yb,ye,kxx,kyy, + * s,nxest, nyest,eta,tol,maxit,nmax,km1,km2,ib1,ib3,nc,intest, + * nrest,nx0,tx,ny0,ty,c,fp,fp0,fpint,coord,f,ff,a,q,bx,by,spx, + * spy,h,index,nummer,wrk,lwrk,ier) + implicit none +c .. +c ..scalar arguments.. + real*8 xb,xe,yb,ye,s,eta,tol,fp,fp0 + integer iopt,m,kxx,kyy,nxest,nyest,maxit,nmax,km1,km2,ib1,ib3, + * nc,intest,nrest,nx0,ny0,lwrk,ier +c ..array arguments.. + real*8 x(m),y(m),z(m),w(m),tx(nmax),ty(nmax),c(nc),fpint(intest), + * coord(intest),f(nc),ff(nc),a(nc,ib1),q(nc,ib3),bx(nmax,km2), + * by(nmax,km2),spx(m,km1),spy(m,km1),h(ib3),wrk(lwrk) + integer index(nrest),nummer(m) +c ..local scalars.. + real*8 acc,arg,cos,dmax,fac1,fac2,fpmax,fpms,f1,f2,f3,hxi,p,pinv, + * piv,p1,p2,p3,sigma,sin,sq,store,wi,x0,x1,y0,y1,zi,eps, + * rn,one,con1,con9,con4,half,ten + integer i,iband,iband1,iband3,iband4,ibb,ichang,ich1,ich3,ii, + * in,irot,iter,i1,i2,i3,j,jrot,jxy,j1,kx,kx1,kx2,ky,ky1,ky2,l, + * la,lf,lh,lwest,lx,ly,l1,l2,n,ncof,nk1x,nk1y,nminx,nminy,nreg, + * nrint,num,num1,nx,nxe,nxx,ny,nye,nyy,n1,rank +c ..local arrays.. + real*8 hx(6),hy(6) +c ..function references.. + real*8 abs,fprati,sqrt + integer min0 +c ..subroutine references.. +c fpback,fpbspl,fpgivs,fpdisc,fporde,fprank,fprota +c .. +c set constants + one = 0.1e+01 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 + half = 0.5e0 + ten = 0.1e+02 +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 kx in x and ky in y; nx=nminx=2*kx+2 and ny=nminy=2*ky+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 +c ichang denotes whether(1) or not(-1) the directions have been inter- +c changed. + ichang = -1 + x0 = xb + x1 = xe + y0 = yb + y1 = ye + kx = kxx + ky = kyy + kx1 = kx+1 + ky1 = ky+1 + nxe = nxest + nye = nyest + eps = sqrt(eta) + if(iopt.lt.0) go to 20 +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s + if(iopt.eq.0) go to 10 + if(fp0.gt.s) go to 20 +c initialization for the least-squares polynomial. + 10 nminx = 2*kx1 + nminy = 2*ky1 + nx = nminx + ny = nminy + ier = -2 + go to 30 + 20 nx = nx0 + ny = ny0 +c main loop for the different sets of knots. m is a save upper bound +c for the number of trials. + 30 do 420 iter=1,m +c find the position of the additional knots which are needed for the +c b-spline representation of s(x,y). + l = nx + do 40 i=1,kx1 + tx(i) = x0 + tx(l) = x1 + l = l-1 + 40 continue + l = ny + do 50 i=1,ky1 + ty(i) = y0 + ty(l) = y1 + l = l-1 + 50 continue +c find nrint, the total number of knot intervals and nreg, the number +c of panels in which the approximation domain is subdivided by the +c intersection of knots. + nxx = nx-2*kx1+1 + nyy = ny-2*ky1+1 + nrint = nxx+nyy + nreg = nxx*nyy +c find the bandwidth of the observation matrix a. +c if necessary, interchange the variables x and y, in order to obtain +c a minimal bandwidth. + iband1 = kx*(ny-ky1)+ky + l = ky*(nx-kx1)+kx + if(iband1.le.l) go to 130 + iband1 = l + ichang = -ichang + do 60 i=1,m + store = x(i) + x(i) = y(i) + y(i) = store + 60 continue + store = x0 + x0 = y0 + y0 = store + store = x1 + x1 = y1 + y1 = store + n = min0(nx,ny) + do 70 i=1,n + store = tx(i) + tx(i) = ty(i) + ty(i) = store + 70 continue + n1 = n+1 + if (nx.lt.ny) go to 80 + if (nx.eq.ny) go to 120 + go to 100 + 80 do 90 i=n1,ny + tx(i) = ty(i) + 90 continue + go to 120 + 100 do 110 i=n1,nx + ty(i) = tx(i) + 110 continue + 120 l = nx + nx = ny + ny = l + l = nxe + nxe = nye + nye = l + l = nxx + nxx = nyy + nyy = l + l = kx + kx = ky + ky = l + kx1 = kx+1 + ky1 = ky+1 + 130 iband = iband1+1 +c arrange the data points according to the panel they belong to. + call fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer,index,nreg) +c find ncof, the number of b-spline coefficients. + nk1x = nx-kx1 + nk1y = ny-ky1 + ncof = nk1x*nk1y +c initialize the observation matrix a. + do 140 i=1,ncof + f(i) = 0. + do 140 j=1,iband + a(i,j) = 0. + 140 continue +c initialize the sum of squared residuals. + fp = 0. +c fetch the data points in the new order. main loop for the +c different panels. + do 250 num=1,nreg +c fix certain constants for the current panel; jrot records the column +c number of the first non-zero element in a row of the observation +c matrix according to a data point of the panel. + num1 = num-1 + lx = num1/nyy + l1 = lx+kx1 + ly = num1-lx*nyy + l2 = ly+ky1 + jrot = lx*nk1y+ly +c test whether there are still data points in the panel. + in = index(num) + 150 if(in.eq.0) go to 250 +c fetch a new data point. + wi = w(in) + zi = z(in)*wi +c evaluate for the x-direction, the (kx+1) non-zero b-splines at x(in). + call fpbspl(tx,nx,kx,x(in),l1,hx) +c evaluate for the y-direction, the (ky+1) non-zero b-splines at y(in). + call fpbspl(ty,ny,ky,y(in),l2,hy) +c store the value of these b-splines in spx and spy respectively. + do 160 i=1,kx1 + spx(in,i) = hx(i) + 160 continue + do 170 i=1,ky1 + spy(in,i) = hy(i) + 170 continue +c initialize the new row of observation matrix. + do 180 i=1,iband + h(i) = 0. + 180 continue +c calculate the non-zero elements of the new row by making the cross +c products of the non-zero b-splines in x- and y-direction. + i1 = 0 + do 200 i=1,kx1 + hxi = hx(i) + j1 = i1 + do 190 j=1,ky1 + j1 = j1+1 + h(j1) = hxi*hy(j)*wi + 190 continue + i1 = i1+nk1y + 200 continue +c rotate the row into triangle by givens transformations . + irot = jrot + do 220 i=1,iband + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 220 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(irot,1),cos,sin) +c apply that transformation to the right hand side. + call fprota(cos,sin,zi,f(irot)) + if(i.eq.iband) go to 230 +c apply that transformation to the left hand side. + i2 = 1 + i3 = i+1 + do 210 j=i3,iband + i2 = i2+1 + call fprota(cos,sin,h(j),a(irot,i2)) + 210 continue + 220 continue +c add the contribution of the row to the sum of squares of residual +c right hand sides. + 230 fp = fp+zi**2 +c find the number of the next data point in the panel. + in = nummer(in) + go to 150 + 250 continue +c find dmax, the maximum value for the diagonal elements in the reduced +c triangle. + dmax = 0. + do 260 i=1,ncof + if(a(i,1).le.dmax) go to 260 + dmax = a(i,1) + 260 continue +c check whether the observation matrix is rank deficient. + sigma = eps*dmax + do 270 i=1,ncof + if(a(i,1).le.sigma) go to 280 + 270 continue +c backward substitution in case of full rank. + call fpback(a,f,ncof,iband,c,nc) + rank = ncof + do 275 i=1,ncof + q(i,1) = a(i,1)/dmax + 275 continue + go to 300 +c in case of rank deficiency, find the minimum norm solution. +c check whether there is sufficient working space + 280 lwest = ncof*iband+ncof+iband + if(lwrk.lt.lwest) go to 780 + do 290 i=1,ncof + ff(i) = f(i) + do 290 j=1,iband + q(i,j) = a(i,j) + 290 continue + lf =1 + lh = lf+ncof + la = lh+iband + call fprank(q,ff,ncof,iband,nc,sigma,c,sq,rank,wrk(la), + * wrk(lf),wrk(lh)) + do 295 i=1,ncof + q(i,1) = q(i,1)/dmax + 295 continue +c add to the sum of squared residuals, the contribution of reducing +c the rank. + fp = fp+sq + 300 if(ier.eq.(-2)) fp0 = fp +c test whether the least-squares spline is an acceptable solution. + if(iopt.lt.0) go to 820 + fpms = fp-s + if(abs(fpms).le.acc) then + if (fp.le.0) go to 815 + go to 820 + endif +c test whether we can accept the choice of knots. + if(fpms.lt.0.) go to 430 +c test whether we cannot further increase the number of knots. + if(ncof.gt.m) go to 790 + ier = 0 +c search where to add a new knot. +c find for each interval the sum of squared residuals fpint for the +c data points having the coordinate belonging to that knot interval. +c calculate also coord which is the same sum, weighted by the position +c of the data points considered. + do 320 i=1,nrint + fpint(i) = 0. + coord(i) = 0. + 320 continue + do 360 num=1,nreg + num1 = num-1 + lx = num1/nyy + l1 = lx+1 + ly = num1-lx*nyy + l2 = ly+1+nxx + jrot = lx*nk1y+ly + in = index(num) + 330 if(in.eq.0) go to 360 + store = 0. + i1 = jrot + do 350 i=1,kx1 + hxi = spx(in,i) + j1 = i1 + do 340 j=1,ky1 + j1 = j1+1 + store = store+hxi*spy(in,j)*c(j1) + 340 continue + i1 = i1+nk1y + 350 continue + store = (w(in)*(z(in)-store))**2 + fpint(l1) = fpint(l1)+store + coord(l1) = coord(l1)+store*x(in) + fpint(l2) = fpint(l2)+store + coord(l2) = coord(l2)+store*y(in) + in = nummer(in) + go to 330 + 360 continue +c find the interval for which fpint is maximal on the condition that +c there still can be added a knot. + 370 l = 0 + fpmax = 0. + l1 = 1 + l2 = nrint + if(nx.eq.nxe) l1 = nxx+1 + if(ny.eq.nye) l2 = nxx + if(l1.gt.l2) go to 810 + do 380 i=l1,l2 + if(fpmax.ge.fpint(i)) go to 380 + l = i + fpmax = fpint(i) + 380 continue +c test whether we cannot further increase the number of knots. + if(l.eq.0) go to 785 +c calculate the position of the new knot. + arg = coord(l)/fpint(l) +c test in what direction the new knot is going to be added. + if(l.gt.nxx) go to 400 +c addition in the x-direction. + jxy = l+kx1 + fpint(l) = 0. + fac1 = tx(jxy)-arg + fac2 = arg-tx(jxy-1) + if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 370 + j = nx + do 390 i=jxy,nx + tx(j+1) = tx(j) + j = j-1 + 390 continue + tx(jxy) = arg + nx = nx+1 + go to 420 +c addition in the y-direction. + 400 jxy = l+ky1-nxx + fpint(l) = 0. + fac1 = ty(jxy)-arg + fac2 = arg-ty(jxy-1) + if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 370 + j = ny + do 410 i=jxy,ny + ty(j+1) = ty(j) + j = j-1 + 410 continue + ty(jxy) = arg + ny = ny+1 +c restart the computations with the new set of knots. + 420 continue +c test whether the least-squares polynomial is a solution of our +c approximation problem. + 430 if(ier.eq.(-2)) go to 830 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline sp(x,y) c +c ***************************************************** c +c we have determined the number of knots and their position. we now c +c compute the b-spline coefficients of the smoothing spline sp(x,y). c +c the observation matrix a is extended by the rows of a matrix, c +c expressing that sp(x,y) must be a polynomial of degree kx in x and c +c ky in y. the corresponding weights of these additional rows are set c +c to 1./p. iteratively we than have to determine the value of p c +c such that f(p)=sum((w(i)*(z(i)-sp(x(i),y(i))))**2) be = s. c +c we already know that the least-squares polynomial corresponds to c +c p=0 and that the least-squares spline corresponds to p=infinity. c +c the iteration process which is proposed here makes use of rational c +c interpolation. since f(p) is a convex and strictly decreasing c +c function of p, it can be approximated by a rational function r(p)= c +c (u*p+v)/(p+w). three values of p(p1,p2,p3) with corresponding values c +c of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the c +c new value of p such that r(p)=s. convergence is guaranteed by taking c +c f1 > 0 and f3 < 0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + kx2 = kx1+1 +c test whether there are interior knots in the x-direction. + if(nk1x.eq.kx1) go to 440 +c evaluate the discotinuity jumps of the kx-th order derivative of +c the b-splines at the knots tx(l),l=kx+2,...,nx-kx-1. + call fpdisc(tx,nx,kx2,bx,nmax) + 440 ky2 = ky1 + 1 +c test whether there are interior knots in the y-direction. + if(nk1y.eq.ky1) go to 450 +c evaluate the discontinuity jumps of the ky-th order derivative of +c the b-splines at the knots ty(l),l=ky+2,...,ny-ky-1. + call fpdisc(ty,ny,ky2,by,nmax) +c initial value for p. + 450 p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + p = 0. + do 460 i=1,ncof + p = p+a(i,1) + 460 continue + rn = ncof + p = rn/p +c find the bandwidth of the extended observation matrix. + iband3 = kx1*nk1y + iband4 = iband3 +1 + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p)=s. + do 770 iter=1,maxit + pinv = one/p +c store the triangularized observation matrix into q. + do 480 i=1,ncof + ff(i) = f(i) + do 470 j=1,iband + q(i,j) = a(i,j) + 470 continue + ibb = iband+1 + do 480 j=ibb,iband4 + q(i,j) = 0. + 480 continue + if(nk1y.eq.ky1) go to 560 +c extend the observation matrix with the rows of a matrix, expressing +c that for x=cst. sp(x,y) must be a polynomial in y of degree ky. + do 550 i=ky2,nk1y + ii = i-ky1 + do 550 j=1,nk1x +c initialize the new row. + do 490 l=1,iband + h(l) = 0. + 490 continue +c fill in the non-zero elements of the row. jrot records the column +c number of the first non-zero element in the row. + do 500 l=1,ky2 + h(l) = by(ii,l)*pinv + 500 continue + zi = 0. + jrot = (j-1)*nk1y+ii +c rotate the new row into triangle by givens transformations without +c square roots. + do 540 irot=jrot,ncof + piv = h(1) + i2 = min0(iband1,ncof-irot) + if(piv.eq.0.) then + if (i2.le.0) go to 550 + go to 520 + endif +c calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),cos,sin) +c apply that givens transformation to the right hand side. + call fprota(cos,sin,zi,ff(irot)) + if(i2.eq.0) go to 550 +c apply that givens transformation to the left hand side. + do 510 l=1,i2 + l1 = l+1 + call fprota(cos,sin,h(l1),q(irot,l1)) + 510 continue + 520 do 530 l=1,i2 + h(l) = h(l+1) + 530 continue + h(i2+1) = 0. + 540 continue + 550 continue + 560 if(nk1x.eq.kx1) go to 640 +c extend the observation matrix with the rows of a matrix expressing +c that for y=cst. sp(x,y) must be a polynomial in x of degree kx. + do 630 i=kx2,nk1x + ii = i-kx1 + do 630 j=1,nk1y +c initialize the new row + do 570 l=1,iband4 + h(l) = 0. + 570 continue +c fill in the non-zero elements of the row. jrot records the column +c number of the first non-zero element in the row. + j1 = 1 + do 580 l=1,kx2 + h(j1) = bx(ii,l)*pinv + j1 = j1+nk1y + 580 continue + zi = 0. + jrot = (i-kx2)*nk1y+j +c rotate the new row into triangle by givens transformations . + do 620 irot=jrot,ncof + piv = h(1) + i2 = min0(iband3,ncof-irot) + if(piv.eq.0.) then + if (i2.le.0) go to 630 + go to 600 + endif +c calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),cos,sin) +c apply that givens transformation to the right hand side. + call fprota(cos,sin,zi,ff(irot)) + if(i2.eq.0) go to 630 +c apply that givens transformation to the left hand side. + do 590 l=1,i2 + l1 = l+1 + call fprota(cos,sin,h(l1),q(irot,l1)) + 590 continue + 600 do 610 l=1,i2 + h(l) = h(l+1) + 610 continue + h(i2+1) = 0. + 620 continue + 630 continue +c find dmax, the maximum value for the diagonal elements in the +c reduced triangle. + 640 dmax = 0. + do 650 i=1,ncof + if(q(i,1).le.dmax) go to 650 + dmax = q(i,1) + 650 continue +c check whether the matrix is rank deficient. + sigma = eps*dmax + do 660 i=1,ncof + if(q(i,1).le.sigma) go to 670 + 660 continue +c backward substitution in case of full rank. + call fpback(q,ff,ncof,iband4,c,nc) + rank = ncof + go to 675 +c in case of rank deficiency, find the minimum norm solution. + 670 lwest = ncof*iband4+ncof+iband4 + if(lwrk.lt.lwest) go to 780 + lf = 1 + lh = lf+ncof + la = lh+iband4 + call fprank(q,ff,ncof,iband4,nc,sigma,c,sq,rank,wrk(la), + * wrk(lf),wrk(lh)) + 675 do 680 i=1,ncof + q(i,1) = q(i,1)/dmax + 680 continue +c compute f(p). + fp = 0. + do 720 num = 1,nreg + num1 = num-1 + lx = num1/nyy + ly = num1-lx*nyy + jrot = lx*nk1y+ly + in = index(num) + 690 if(in.eq.0) go to 720 + store = 0. + i1 = jrot + do 710 i=1,kx1 + hxi = spx(in,i) + j1 = i1 + do 700 j=1,ky1 + j1 = j1+1 + store = store+hxi*spy(in,j)*c(j1) + 700 continue + i1 = i1+nk1y + 710 continue + fp = fp+(w(in)*(z(in)-store))**2 + in = nummer(in) + go to 690 + 720 continue +c test whether the approximation sp(x,y) is an acceptable solution. + fpms = fp-s + if(abs(fpms).le.acc) go to 820 +c test whether the maximum allowable number of iterations has been +c reached. + if(iter.eq.maxit) go to 795 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 740 + if((f2-f3).gt.acc) go to 730 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 + p2*con1 + go to 770 + 730 if(f2.lt.0.) ich3 = 1 + 740 if(ich1.ne.0) go to 760 + if((f1-f2).gt.acc) go to 750 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 770 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 770 + 750 if(f2.gt.0.) ich1 = 1 +c test whether the iteration process proceeds as theoretically +c expected. + 760 if(f2.ge.f1 .or. f2.le.f3) go to 800 +c find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 770 continue +c error codes and messages. + 780 ier = lwest + go to 830 + 785 ier = 5 + go to 830 + 790 ier = 4 + go to 830 + 795 ier = 3 + go to 830 + 800 ier = 2 + go to 830 + 810 ier = 1 + go to 830 + 815 ier = -1 + fp = 0. + 820 if(ncof.ne.rank) ier = -rank +c test whether x and y are in the original order. + 830 if(ichang.lt.0) go to 930 +c if not, interchange x and y once more. + l1 = 1 + do 840 i=1,nk1x + l2 = i + do 840 j=1,nk1y + f(l2) = c(l1) + l1 = l1+1 + l2 = l2+nk1x + 840 continue + do 850 i=1,ncof + c(i) = f(i) + 850 continue + do 860 i=1,m + store = x(i) + x(i) = y(i) + y(i) = store + 860 continue + n = min0(nx,ny) + do 870 i=1,n + store = tx(i) + tx(i) = ty(i) + ty(i) = store + 870 continue + n1 = n+1 + if (nx.lt.ny) go to 880 + if (nx.eq.ny) go to 920 + go to 900 + 880 do 890 i=n1,ny + tx(i) = ty(i) + 890 continue + go to 920 + 900 do 910 i=n1,nx + ty(i) = tx(i) + 910 continue + 920 l = nx + nx = ny + ny = l + 930 if(iopt.lt.0) go to 940 + nx0 = nx + ny0 = ny + 940 return + end + diff --git a/fitpack/fpsysy.f b/fitpack/fpsysy.f new file mode 100644 index 0000000..5224f75 --- /dev/null +++ b/fitpack/fpsysy.f @@ -0,0 +1,57 @@ + recursive subroutine fpsysy(a,n,g) + implicit none +c subroutine fpsysy solves a linear n x n symmetric system +c (a) * (b) = (g) +c on input, vector g contains the right hand side ; on output it will +c contain the solution (b). +c .. +c ..scalar arguments.. + integer n +c ..array arguments.. + real*8 a(6,6),g(6) +c ..local scalars.. + real*8 fac + integer i,i1,j,k +c .. + g(1) = g(1)/a(1,1) + if(n.eq.1) return +c decomposition of the symmetric matrix (a) = (l) * (d) *(l)' +c with (l) a unit lower triangular matrix and (d) a diagonal +c matrix + do 10 k=2,n + a(k,1) = a(k,1)/a(1,1) + 10 continue + do 40 i=2,n + i1 = i-1 + do 30 k=i,n + fac = a(k,i) + do 20 j=1,i1 + fac = fac-a(j,j)*a(k,j)*a(i,j) + 20 continue + a(k,i) = fac + if(k.gt.i) a(k,i) = fac/a(i,i) + 30 continue + 40 continue +c solve the system (l)*(d)*(l)'*(b) = (g). +c first step : solve (l)*(d)*(c) = (g). + do 60 i=2,n + i1 = i-1 + fac = g(i) + do 50 j=1,i1 + fac = fac-g(j)*a(j,j)*a(i,j) + 50 continue + g(i) = fac/a(i,i) + 60 continue +c second step : solve (l)'*(b) = (c) + i = n + do 80 j=2,n + i1 = i + i = i-1 + fac = g(i) + do 70 k=i1,n + fac = fac-g(k)*a(k,i) + 70 continue + g(i) = fac + 80 continue + return + end diff --git a/fitpack/fptrnp.f b/fitpack/fptrnp.f new file mode 100644 index 0000000..599bfea --- /dev/null +++ b/fitpack/fptrnp.f @@ -0,0 +1,107 @@ + recursive subroutine fptrnp(m,mm,idim,n,nr,sp,p,b,z,a,q,right) + implicit none +c subroutine fptrnp reduces the (m+n-7) x (n-4) matrix a to upper +c triangular form and applies the same givens transformations to +c the (m) x (mm) x (idim) matrix z to obtain the (n-4) x (mm) x +c (idim) matrix q +c .. +c ..scalar arguments.. + real*8 p + integer m,mm,idim,n +c ..array arguments.. + real*8 sp(m,4),b(n,5),z(m*mm*idim),a(n,5),q((n-4)*mm*idim), + * right(mm*idim) + integer nr(m) +c ..local scalars.. + real*8 cos,pinv,piv,sin,one + integer i,iband,irot,it,ii,i2,i3,j,jj,l,mid,nmd,m2,m3, + * nrold,n4,number,n1 +c ..local arrays.. + real*8 h(7) +c ..subroutine references.. +c fpgivs,fprota +c .. + one = 1 + if(p.gt.0.) pinv = one/p + n4 = n-4 + mid = mm*idim + m2 = m*mm + m3 = n4*mm +c reduce the matrix (a) to upper triangular form (r) using givens +c rotations. apply the same transformations to the rows of matrix z +c to obtain the mm x (n-4) matrix g. +c store matrix (r) into (a) and g into q. +c initialization. + nmd = n4*mid + do 50 i=1,nmd + q(i) = 0. + 50 continue + do 100 i=1,n4 + do 100 j=1,5 + a(i,j) = 0. + 100 continue + nrold = 0 +c iband denotes the bandwidth of the matrices (a) and (r). + iband = 4 + do 750 it=1,m + number = nr(it) + 150 if(nrold.eq.number) go to 300 + if(p.le.0.) go to 700 + iband = 5 +c fetch a new row of matrix (b). + n1 = nrold+1 + do 200 j=1,5 + h(j) = b(n1,j)*pinv + 200 continue +c find the appropriate column of q. + do 250 j=1,mid + right(j) = 0. + 250 continue + irot = nrold + go to 450 +c fetch a new row of matrix (sp). + 300 h(iband) = 0. + do 350 j=1,4 + h(j) = sp(it,j) + 350 continue +c find the appropriate column of q. + j = 0 + do 400 ii=1,idim + l = (ii-1)*m2+(it-1)*mm + do 400 jj=1,mm + j = j+1 + l = l+1 + right(j) = z(l) + 400 continue + irot = number +c rotate the new row of matrix (a) into triangle. + 450 do 600 i=1,iband + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 600 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(irot,1),cos,sin) +c apply that transformation to the rows of matrix q. + j = 0 + do 500 ii=1,idim + l = (ii-1)*m3+irot + do 500 jj=1,mm + j = j+1 + call fprota(cos,sin,right(j),q(l)) + l = l+n4 + 500 continue +c apply that transformation to the columns of (a). + if(i.eq.iband) go to 650 + i2 = 1 + i3 = i+1 + do 550 j=i3,iband + i2 = i2+1 + call fprota(cos,sin,h(j),a(irot,i2)) + 550 continue + 600 continue + 650 if(nrold.eq.number) go to 750 + 700 nrold = nrold+1 + go to 150 + 750 continue + return + end diff --git a/fitpack/fptrpe.f b/fitpack/fptrpe.f new file mode 100644 index 0000000..7ddf6ee --- /dev/null +++ b/fitpack/fptrpe.f @@ -0,0 +1,214 @@ + recursive subroutine fptrpe(m,mm,idim,n,nr,sp,p,b,z,a,aa,q,right) + implicit none +c subroutine fptrpe reduces the (m+n-7) x (n-7) cyclic bandmatrix a +c to upper triangular form and applies the same givens transformations +c to the (m) x (mm) x (idim) matrix z to obtain the (n-7) x (mm) x +c (idim) matrix q. +c .. +c ..scalar arguments.. + real*8 p + integer m,mm,idim,n +c ..array arguments.. + real*8 sp(m,4),b(n,5),z(m*mm*idim),a(n,5),aa(n,4),q((n-7)*mm*idim) + *, + * right(mm*idim) + integer nr(m) +c ..local scalars.. + real*8 co,pinv,piv,si,one + integer i,irot,it,ii,i2,i3,j,jj,l,mid,nmd,m2,m3, + * nrold,n4,number,n1,n7,n11,m1 + integer i1, ij,j1,jk,jper,l0,l1, ik +c ..local arrays.. + real*8 h(5),h1(5),h2(4) +c ..subroutine references.. +c fpgivs,fprota +c .. + one = 1 + if(p.gt.0.) pinv = one/p + n4 = n-4 + n7 = n-7 + n11 = n-11 + mid = mm*idim + m2 = m*mm + m3 = n7*mm + m1 = m-1 +c we determine the matrix (a) and then we reduce her to +c upper triangular form (r) using givens rotations. +c we apply the same transformations to the rows of matrix +c z to obtain the (mm) x (n-7) matrix g. +c we store matrix (r) into a and aa, g into q. +c the n7 x n7 upper triangular matrix (r) has the form +c | a1 ' | +c (r) = | ' a2 | +c | 0 ' | +c with (a2) a n7 x 4 matrix and (a1) a n11 x n11 upper +c triangular matrix of bandwidth 5. +c initialization. + nmd = n7*mid + do 50 i=1,nmd + q(i) = 0. + 50 continue + do 100 i=1,n4 + a(i,5) = 0. + do 100 j=1,4 + a(i,j) = 0. + aa(i,j) = 0. + 100 continue + jper = 0 + nrold = 0 + do 760 it=1,m1 + number = nr(it) + 120 if(nrold.eq.number) go to 180 + if(p.le.0.) go to 740 +c fetch a new row of matrix (b). + n1 = nrold+1 + do 140 j=1,5 + h(j) = b(n1,j)*pinv + 140 continue +c find the appropriate row of q. + do 160 j=1,mid + right(j) = 0. + 160 continue + go to 240 +c fetch a new row of matrix (sp) + 180 h(5) = 0. + do 200 j=1,4 + h(j) = sp(it,j) + 200 continue +c find the appropriate row of q. + j = 0 + do 220 ii=1,idim + l = (ii-1)*m2+(it-1)*mm + do 220 jj=1,mm + j = j+1 + l = l+1 + right(j) = z(l) + 220 continue +c test whether there are non-zero values in the new row of (a) +c corresponding to the b-splines n(j,*),j=n7+1,...,n4. + 240 if(nrold.lt.n11) go to 640 + if(jper.ne.0) go to 320 +c initialize the matrix (aa). + jk = n11+1 + do 300 i=1,4 + ik = jk + do 260 j=1,5 + if(ik.le.0) go to 280 + aa(ik,i) = a(ik,j) + ik = ik-1 + 260 continue + 280 jk = jk+1 + 300 continue + jper = 1 +c if one of the non-zero elements of the new row corresponds to one of +c the b-splines n(j;*),j=n7+1,...,n4,we take account of the periodicity +c conditions for setting up this row of (a). + 320 do 340 i=1,4 + h1(i) = 0. + h2(i) = 0. + 340 continue + h1(5) = 0. + j = nrold-n11 + do 420 i=1,5 + j = j+1 + l0 = j + 360 l1 = l0-4 + if(l1.le.0) go to 400 + if(l1.le.n11) go to 380 + l0 = l1-n11 + go to 360 + 380 h1(l1) = h(i) + go to 420 + 400 h2(l0) = h2(l0) + h(i) + 420 continue +c rotate the new row of (a) into triangle. + if(n11.le.0) go to 560 +c rotations with the rows 1,2,...,n11 of (a). + do 540 irot=1,n11 + piv = h1(1) + i2 = min0(n11-irot,4) + if(piv.eq.0.) go to 500 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(irot,1),co,si) +c apply that transformation to the columns of matrix q. + j = 0 + do 440 ii=1,idim + l = (ii-1)*m3+irot + do 440 jj=1,mm + j = j+1 + call fprota(co,si,right(j),q(l)) + l = l+n7 + 440 continue +c apply that transformation to the rows of (a) with respect to aa. + do 460 i=1,4 + call fprota(co,si,h2(i),aa(irot,i)) + 460 continue +c apply that transformation to the rows of (a) with respect to a. + if(i2.eq.0) go to 560 + do 480 i=1,i2 + i1 = i+1 + call fprota(co,si,h1(i1),a(irot,i1)) + 480 continue + 500 do 520 i=1,i2 + h1(i) = h1(i+1) + 520 continue + h1(i2+1) = 0. + 540 continue +c rotations with the rows n11+1,...,n7 of a. + 560 do 620 irot=1,4 + ij = n11+irot + if(ij.le.0) go to 620 + piv = h2(irot) + if(piv.eq.0.) go to 620 +c calculate the parameters of the givens transformation. + call fpgivs(piv,aa(ij,irot),co,si) +c apply that transformation to the columns of matrix q. + j = 0 + do 580 ii=1,idim + l = (ii-1)*m3+ij + do 580 jj=1,mm + j = j+1 + call fprota(co,si,right(j),q(l)) + l = l+n7 + 580 continue + if(irot.eq.4) go to 620 +c apply that transformation to the rows of (a) with respect to aa. + j1 = irot+1 + do 600 i=j1,4 + call fprota(co,si,h2(i),aa(ij,i)) + 600 continue + 620 continue + go to 720 +c rotation into triangle of the new row of (a), in case the elements +c corresponding to the b-splines n(j;*),j=n7+1,...,n4 are all zero. + 640 irot =nrold + do 700 i=1,5 + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 700 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(irot,1),co,si) +c apply that transformation to the columns of matrix g. + j = 0 + do 660 ii=1,idim + l = (ii-1)*m3+irot + do 660 jj=1,mm + j = j+1 + call fprota(co,si,right(j),q(l)) + l = l+n7 + 660 continue +c apply that transformation to the rows of (a). + if(i.eq.5) go to 700 + i2 = 1 + i3 = i+1 + do 680 j=i3,5 + i2 = i2+1 + call fprota(co,si,h(j),a(irot,i2)) + 680 continue + 700 continue + 720 if(nrold.eq.number) go to 760 + 740 nrold = nrold+1 + go to 120 + 760 continue + return + end diff --git a/fitpack/insert.f b/fitpack/insert.f new file mode 100644 index 0000000..2d31d42 --- /dev/null +++ b/fitpack/insert.f @@ -0,0 +1,103 @@ + recursive subroutine insert(iopt,t,n,c,k,x,tt,nn,cc,nest,ier) + implicit none +c subroutine insert inserts a new knot x into a spline function s(x) +c of degree k and calculates the b-spline representation of s(x) with +c respect to the new set of knots. in addition, if iopt.ne.0, s(x) +c will be considered as a periodic spline with period per=t(n-k)-t(k+1) +c satisfying the boundary constraints +c t(i+n-2*k-1) = t(i)+per ,i=1,2,...,2*k+1 +c c(i+n-2*k-1) = c(i) ,i=1,2,...,k +c in that case, the knots and b-spline coefficients returned will also +c satisfy these boundary constraints, i.e. +c tt(i+nn-2*k-1) = tt(i)+per ,i=1,2,...,2*k+1 +c cc(i+nn-2*k-1) = cc(i) ,i=1,2,...,k +c +c calling sequence: +c call insert(iopt,t,n,c,k,x,tt,nn,cc,nest,ier) +c +c input parameters: +c iopt : integer flag, specifying whether (iopt.ne.0) or not (iopt=0) +c the given spline must be considered as being periodic. +c t : array,length nest, which contains the position of the knots. +c n : integer, giving the total number of knots of s(x). +c c : array,length nest, which contains the b-spline coefficients. +c k : integer, giving the degree of s(x). +c x : real, which gives the location of the knot to be inserted. +c nest : integer specifying the dimension of the arrays t,c,tt and cc +c nest > n. +c +c output parameters: +c tt : array,length nest, which contains the position of the knots +c after insertion. +c nn : integer, giving the total number of knots after insertion +c cc : array,length nest, which contains the b-spline coefficients +c of s(x) with respect to the new set of knots. +c ier : error flag +c ier = 0 : normal return +c ier =10 : invalid input data (see restrictions) +c +c restrictions: +c nest > n +c t(k+1) <= x <= t(n-k) +c in case of a periodic spline (iopt.ne.0) there must be +c either at least k interior knots t(j) satisfying t(k+1) +#include +#include + +#include + +extern "C" { +void surfit(int* iopt, + int* m, + double* x, + double* y, + double* z, + double* w, + double* xb, + double* xe, + double* yb, + double* ye, + int* kx, + int* ky, + double* s, + int* nxest, + int* nyest, + int* nmax, + double* eps, + int* nx, + double* tx, + int* ny, + double* ty, + double* c, + double* fp, + double* wrk1, + int* lwrk1, + double* wrk2, + int* lwrk2, + int* iwrk, + int* kwrk, + int* ier); + +void bispev(double* tx, + int* nx, + double* ty, + int* ny, + double* c, + int* kx, + int* ky, + double* x, + int* mx, + double* y, + int* my, + double* z, + double* wrk, + int* lwrk, + int* iwrk, + int* kwrk, + int* ier); + +void parder(double* tx, + int* nx, + double* ty, + int* ny, + double* c, + int* kx, + int* ky, + int* nux, + int* nuy, + double* x, + int* mx, + double* y, + int* my, + double* z, + double* wrk, + int* lwrk, + int* iwrk, + int* kwrk, + int* ier); + + +void sphere(int* iopt, + int* m, + double* teta, + double* phi, + double* r, + double* w, + double* s, + int* ntest, + int* npest, + double* eps, + int* nt, + double* tt, + int* np, + double* tp, + double* c, + double* fp, + double* wrk1, + int* lwrk1, + double* wrk2, + int* lwrk2, + int* iwrk, + int* kwrk, + int* ier); +} + + + +namespace mcc::bsplines +{ + +template +int fitpack_sphere_smooth(const TethaT& tetha, + const PhiT& phi, + const FuncT& func, + const WeightT& weight, + double s_par, + int& ntest, + int& npest, + TKnotT& tetha_knots, + PKnotT& phi_knots, + CoeffT& coeffs, + double& resi2_sum, + double eps = std::numeric_limits::epsilon()) + requires((std::ranges::contiguous_range || std::convertible_to) && + std::ranges::output_range) +{ + static_assert(std::same_as, double> && + std::same_as, double> && + std::same_as, double> && + std::same_as, double> && + std::same_as, double> && + std::same_as, double>, + "Input ranges elements type must be double!"); + + if constexpr (std::ranges::contiguous_range) { + static_assert(std::same_as, double>, + "Input ranges elements type must be double!"); + } + + + static_assert(IOPT != -1 || IOPT != 0 || IOPT != 1, "Invalid IOPT template parameter value!"); + + + int m = std::min(std::min(std::ranges::size(tetha), std::ranges::size(phi)), std::ranges::size(func)); + if (m < 2) { + return 10; + } + + int res = 0; + + /* do checking here to avoid possibly unnecessary memory allocations */ + + // number of knots must be >= 8 for the qubic b-splines + if (ntest < 8 || npest < 8) { + return 10; + } + + if constexpr (std::ranges::contiguous_range) { + m = std::min(m, std::ranges::size(weight)); + if (m < 2) { + return 10; + } + } + + if (s_par <= 0.0) { + return 10; + } + + if (eps <= 0.0 || eps >= 1.0) { + return 10; + } + + int nt = std::ranges::size(tetha_knots); + int np = std::ranges::size(phi_knots); + + if (nt < ntest) { + std::ranges::fill_n(std::back_inserter(tetha_knots), ntest - nt, 0.0); + } + if (np < npest) { + std::ranges::fill_n(std::back_inserter(phi_knots), npest - np, 0.0); + } + + + // compute working arrays sizes according to sphere.f + const int u = ntest - 7; + const int v = npest - 7; + const int uv = u * v; + const int v2 = v * v; + + int lwrk1 = 185 + 52 * v + 10 * u + 14 * uv + 8 * (u - 1) * v2 + 8 * m; + int lwrk2 = 48 + 21 * v + 7 * uv + 4 * (u - 1) * v2; + int kwrk = m + uv; + + std::vector wrk1(lwrk1); + std::vector wrk2(lwrk2); + std::vector iwrk(kwrk); + + const int n_coeffs = (ntest - 4) * (npest - 4); + if (std::ranges::size(coeffs) < n_coeffs) { // resize + std::ranges::fill_n(std::back_inserter(coeffs), n_coeffs - std::ranges::size(coeffs), 0.0); + } + + int iopt = IOPT; + + auto tetha_ptr = const_cast(std::ranges::data(tetha)); + auto phi_ptr = const_cast(std::ranges::data(phi)); + auto func_ptr = const_cast(std::ranges::data(func)); + auto tetha_knots_ptr = const_cast(std::ranges::data(tetha_knots)); + auto phi_knots_ptr = const_cast(std::ranges::data(phi_knots)); + + if constexpr (std::ranges::contiguous_range) { + auto weight_ptr = const_cast(std::ranges::data(weight)); + + sphere(&iopt, &m, tetha_ptr, phi_ptr, func_ptr, weight_ptr, &s_par, &nt, &np, &eps, &ntest, tetha_knots_ptr, + &npest, phi_knots_ptr, std::ranges::data(coeffs), &resi2_sum, wrk1.data(), &lwrk1, wrk2.data(), &lwrk2, + iwrk.data(), &kwrk, &res); + // sphere(&iopt, &m, std::ranges::data(tetha), std::ranges::data(phi), std::ranges::data(func), + // std::ranges::data(weight), &s_par, &ntest, &npest, &eps, &ntest, std::ranges::data(tetha_knots), + // &npest, std::ranges::data(phi_knots), std::ranges::data(coeffs), &resi2_sum, wrk1.data(), &lwrk1, + // wrk2.data(), &lwrk2, iwrk.data(), &kwrk, &res); + } else { + std::vector weight_vec(m, weight); + + sphere(&iopt, &m, tetha_ptr, phi_ptr, func_ptr, weight_vec.data(), &s_par, &nt, &np, &eps, &ntest, + tetha_knots_ptr, &npest, phi_knots_ptr, std::ranges::data(coeffs), &resi2_sum, wrk1.data(), &lwrk1, + wrk2.data(), &lwrk2, iwrk.data(), &kwrk, &res); + // res = sphere(&iopt, &m, std::ranges::data(tetha), std::ranges::data(phi), std::ranges::data(func), + // weight_vec.data(), &s_par, &ntest, &npest, &eps, &ntest, std::ranges::data(tetha_knots), &npest, + // std::ranges::data(phi_knots), std::ranges::data(coeffs), &resi2_sum, wrk1.get(), &lwrk1, + // wrk2.get(), &lwrk2, iwrk.get(), &kwrk, &res); + } + + + return res; +} + +/* + least-squares fitting (iopt=-1) +*/ +template +int fitpack_sphere_fit(const TethaT& tetha, + const PhiT& phi, + const FuncT& func, + const WeightT& weight, + TKnotT& tetha_knots, + PKnotT& phi_knots, + CoeffT& coeffs, + double& resi2_sum, + double eps = std::numeric_limits::epsilon()) +{ + const double s = 100.0; + int nt = std::ranges::size(tetha_knots); + int np = std::ranges::size(phi_knots); + + return fitpack_sphere_smooth<-1>(tetha, phi, func, weight, s, nt, np, tetha_knots, phi_knots, coeffs, resi2_sum, + eps); +} + + +template +int fitpack_eval_spl2d(const TXT& tx, + const TYT& ty, + const CoeffT& coeffs, + const XT& x, + const YT& y, + FuncT& func, + int kx = 3, + int ky = 3) +{ + static_assert(std::same_as, double> && + std::same_as, double> && + std::same_as, double> && + std::same_as, double> && + std::same_as, double> && + std::same_as, double>, + "Input ranges elements type must be double!"); + + if (kx < 0 || ky < 0) { + return 10; + } + + + int ier = 0; + + int ntx = std::ranges::size(tx); + int nty = std::ranges::size(ty); + + auto n_coeffs = (ntx - kx - 1) * (nty - ky - 1); + if (std::ranges::size(coeffs) < n_coeffs) { + return 10; + } + + int mx = std::ranges::size(x), my = std::ranges::size(y); + int N = mx * my; + + if (std::ranges::size(func) < N) { + std::ranges::fill_n(std::back_inserter(func), N - std::ranges::size(func), 0.0); + } + + // compute sizes of working arrays according to bispev.f + int lwrk = mx * (kx + 1) + my * (ky + 1); + std::vector wrk(lwrk); + + int kwrk = mx + my; + std::vector iwrk(kwrk); + + auto tx_ptr = const_cast(std::ranges::data(tx)); + auto ty_ptr = const_cast(std::ranges::data(ty)); + auto coeffs_ptr = const_cast(std::ranges::data(coeffs)); + auto x_ptr = const_cast(std::ranges::data(x)); + auto y_ptr = const_cast(std::ranges::data(y)); + + bispev(tx_ptr, &ntx, ty_ptr, &nty, coeffs_ptr, &kx, &ky, x_ptr, &mx, y_ptr, &my, std::ranges::data(func), + wrk.data(), &lwrk, iwrk.data(), &kwrk, &ier); + + return ier; +} + + +// scalar x,y version +template +int fitpack_eval_spl2d(const TXT& tx, + const TYT& ty, + const CoeffT& coeffs, + const XT& x, + const YT& y, + FuncT& func, + int kx = 3, + int ky = 3) +{ + static_assert(std::same_as, double> && + std::same_as, double> && + std::same_as, double>, + "Input ranges elements type must be double!"); + + static_assert( + std::convertible_to && std::convertible_to && std::convertible_to, + "XT, YT and FuncT types must be a scalar convertible to double!"); + + auto xv = std::vector(1, x); + auto yv = std::vector(1, y); + auto fv = std::vector(1, func); + + return fitpack_eval_spl2d(tx, ty, coeffs, xv, yv, fv, kx, ky); +} + +} // namespace mcc::fitpack diff --git a/fitpack/parcur.f b/fitpack/parcur.f new file mode 100644 index 0000000..65fa9fa --- /dev/null +++ b/fitpack/parcur.f @@ -0,0 +1,335 @@ + recursive subroutine parcur(iopt,ipar,idim,m,u,mx,x,w,ub,ue,k,s, + * nest,n,t,nc,c,fp,wrk,lwrk,iwrk,ier) + implicit none +c given the ordered set of m points x(i) in the idim-dimensional space +c and given also a corresponding set of strictly increasing values u(i) +c and the set of positive numbers w(i),i=1,2,...,m, subroutine parcur +c determines a smooth approximating spline curve s(u), i.e. +c x1 = s1(u) +c x2 = s2(u) ub <= u <= ue +c ......... +c xidim = sidim(u) +c with sj(u),j=1,2,...,idim spline functions of degree k with common +c knots t(j),j=1,2,...,n. +c if ipar=1 the values ub,ue and u(i),i=1,2,...,m must be supplied by +c the user. if ipar=0 these values are chosen automatically by parcur +c as v(1) = 0 +c v(i) = v(i-1) + dist(x(i),x(i-1)) ,i=2,3,...,m +c u(i) = v(i)/v(m) ,i=1,2,...,m +c ub = u(1) = 0, ue = u(m) = 1. +c if iopt=-1 parcur calculates the weighted least-squares spline curve +c according to a given set of knots. +c if iopt>=0 the number of knots of the splines sj(u) and the position +c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- +c ness of s(u) is then achieved by minimalizing the discontinuity +c jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,..., +c n-k-1. the amount of smoothness is determined by the condition that +c f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non- +c negative constant, called the smoothing factor. +c the fit s(u) is given in the b-spline representation and can be +c evaluated by means of subroutine curev. +c +c calling sequence: +c call parcur(iopt,ipar,idim,m,u,mx,x,w,ub,ue,k,s,nest,n,t,nc,c, +c * fp,wrk,lwrk,iwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a weighted +c least-squares spline curve (iopt=-1) or a smoothing spline +c curve (iopt=0 or 1) must be determined.if iopt=0 the routine +c will start with an initial set of knots t(i)=ub,t(i+k+1)=ue, +c i=1,2,...,k+1. if iopt=1 the routine will continue with the +c knots found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately +c preceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c ipar : integer flag. on entry ipar must specify whether (ipar=1) +c the user will supply the parameter values u(i),ub and ue +c or whether (ipar=0) these values are to be calculated by +c parcur. unchanged on exit. +c idim : integer. on entry idim must specify the dimension of the +c curve. 0 < idim < 11. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m > k. unchanged on exit. +c u : real array of dimension at least (m). in case ipar=1,before +c entry, u(i) must be set to the i-th value of the parameter +c variable u for i=1,2,...,m. these values must then be +c supplied in strictly ascending order and will be unchanged +c on exit. in case ipar=0, on exit,array u will contain the +c values u(i) as determined by parcur. +c mx : integer. on entry mx must specify the actual dimension of +c the array x as declared in the calling (sub)program. mx must +c not be too small (see x). unchanged on exit. +c x : real array of dimension at least idim*m. +c before entry, x(idim*(i-1)+j) must contain the j-th coord- +c inate of the i-th data point for i=1,2,...,m and j=1,2,..., +c idim. unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) +c must be set to the i-th value in the set of weights. the +c w(i) must be strictly positive. unchanged on exit. +c see also further comments. +c ub,ue : real values. on entry (in case ipar=1) ub and ue must +c contain the lower and upper bound for the parameter u. +c ub <=u(1), ue>= u(m). if ipar = 0 these values will +c automatically be set to 0 and 1 by parcur. +c k : integer. on entry k must specify the degree of the splines. +c 1<=k<=5. it is recommended to use cubic splines (k=3). +c the user is strongly dissuaded from choosing k even,together +c with a small s-value. unchanged on exit. +c s : real.on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments. +c nest : integer. on entry nest must contain an over-estimate of the +c total number of knots of the splines returned, to indicate +c the storage space available to the routine. nest >=2*k+2. +c in most practical situation nest=m/2 will be sufficient. +c always large enough is nest=m+k+1, the number of knots +c needed for interpolation (s=0). unchanged on exit. +c n : integer. +c unless ier = 10 (in case iopt >=0), n will contain the +c total number of knots of the smoothing spline curve returned +c if the computation mode iopt=1 is used this value of n +c should be left unchanged between subsequent calls. +c in case iopt=-1, the value of n must be specified on entry. +c t : real array of dimension at least (nest). +c on successful exit, this array will contain the knots of the +c spline curve,i.e. the position of the interior knots t(k+2), +c t(k+3),..,t(n-k-1) as well as the position of the additional +c t(1)=t(2)=...=t(k+1)=ub and t(n-k)=...=t(n)=ue needed for +c the b-spline representation. +c if the computation mode iopt=1 is used, the values of t(1), +c t(2),...,t(n) should be left unchanged between subsequent +c calls. if the computation mode iopt=-1 is used, the values +c t(k+2),...,t(n-k-1) must be supplied by the user, before +c entry. see also the restrictions (ier=10). +c nc : integer. on entry nc must specify the actual dimension of +c the array c as declared in the calling (sub)program. nc +c must not be too small (see c). unchanged on exit. +c c : real array of dimension at least (nest*idim). +c on successful exit, this array will contain the coefficients +c in the b-spline representation of the spline curve s(u),i.e. +c the b-spline coefficients of the spline sj(u) will be given +c in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim. +c fp : real. unless ier = 10, fp contains the weighted sum of +c squared residuals of the spline curve returned. +c wrk : real array of dimension at least m*(k+1)+nest*(6+idim+3*k). +c used as working space. if the computation mode iopt=1 is +c used, the values wrk(1),...,wrk(n) should be left unchanged +c between subsequent calls. +c lwrk : integer. on entry,lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program. lwrk +c must not be too small (see wrk). unchanged on exit. +c iwrk : integer array of dimension at least (nest). +c used as working space. if the computation mode iopt=1 is +c used,the values iwrk(1),...,iwrk(n) should be left unchanged +c between subsequent calls. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the curve returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the curve returned is an interpolating +c spline curve (fp=0). +c ier=-2 : normal return. the curve returned is the weighted least- +c squares polynomial curve of degree k.in this extreme case +c fp gives the upper bound fp0 for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameter nest. +c probably causes : nest too small. if nest is already +c large (say nest > m/2), it may also indicate that s is +c too small +c the approximation returned is the least-squares spline +c curve according to the knots t(1),t(2),...,t(n). (n=nest) +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline curve +c with fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing curve +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 1<=k<=5, m>k, nest>2*k+2, w(i)>0,i=1,2,...,m +c 0<=ipar<=1, 0=(k+1)*m+nest*(6+idim+3*k), +c nc>=nest*idim +c if ipar=0: sum j=1,idim (x(idim*i+j)-x(idim*(i-1)+j))**2>0 +c i=1,2,...,m-1. +c if ipar=1: ub<=u(1)=0: s>=0 +c if s=0 : nest >= m+k+1 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the curve will be too smooth and signal will be +c lost ; if s is too small the curve will pick up too much noise. in +c the extreme cases the program will return an interpolating curve if +c s=0 and the least-squares polynomial curve of degree k if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c x(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in x(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the least-squares +c polynomial curve and the upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximating curve shows more detail) to obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if parcur is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c curve underlying the data. but, if the computation mode iopt=1 is +c used, the knots returned may also depend on the s-values at previous +c calls (if these were smaller). therefore, if after a number of +c trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c parcur once more with the selected value for s but now with iopt=0. +c indeed, parcur may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c +c the form of the approximating curve can strongly be affected by +c the choice of the parameter values u(i). if there is no physical +c reason for choosing a particular parameter u, often good results +c will be obtained with the choice of parcur (in case ipar=0), i.e. +c v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m +c where +c q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 ) +c other possibilities for q(i) are +c q(i)= sum j=1,idim (xj(i)-xj(i-1))**2 +c q(i)= sum j=1,idim abs(xj(i)-xj(i-1)) +c q(i)= max j=1,idim abs(xj(i)-xj(i-1)) +c q(i)= 1 +c +c other subroutines required: +c fpback,fpbspl,fpchec,fppara,fpdisc,fpgivs,fpknot,fprati,fprota +c +c references: +c dierckx p. : algorithms for smoothing data with periodic and +c parametric splines, computer graphics and image +c processing 20 (1982) 171-184. +c dierckx p. : algorithms for smoothing data with periodic and param- +c etric splines, report tw55, dept. computer science, +c k.u.leuven, 1981. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + real*8 ub,ue,s,fp + integer iopt,ipar,idim,m,mx,k,nest,n,nc,lwrk,ier +c ..array arguments.. + real*8 u(m),x(mx),w(m),t(nest),c(nc),wrk(lwrk) + integer iwrk(nest) +c ..local scalars.. + real*8 tol,dist + integer i,ia,ib,ifp,ig,iq,iz,i1,i2,j,k1,k2,lwest,maxit,nmin,ncc +c ..function references + real*8 sqrt +c .. +c we set up the parameters tol and maxit + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 90 + if(ipar.lt.0 .or. ipar.gt.1) go to 90 + if(idim.le.0 .or. idim.gt.10) go to 90 + if(k.le.0 .or. k.gt.5) go to 90 + k1 = k+1 + k2 = k1+1 + nmin = 2*k1 + if(m.lt.k1 .or. nest.lt.nmin) go to 90 + ncc = nest*idim + if(mx.lt.m*idim .or. nc.lt.ncc) go to 90 + lwest = m*k1+nest*(6+idim+3*k) + if(lwrk.lt.lwest) go to 90 + if(ipar.ne.0 .or. iopt.gt.0) go to 40 + i1 = 0 + i2 = idim + u(1) = 0. + do 20 i=2,m + dist = 0. + do 10 j=1,idim + i1 = i1+1 + i2 = i2+1 + dist = dist+(x(i2)-x(i1))**2 + 10 continue + u(i) = u(i-1)+sqrt(dist) + 20 continue + if(u(m).le.0.) go to 90 + do 30 i=2,m + u(i) = u(i)/u(m) + 30 continue + ub = 0. + ue = 1. + u(m) = ue + 40 if(ub.gt.u(1) .or. ue.lt.u(m) .or. w(1).le.0.) go to 90 + do 50 i=2,m + if(u(i-1).ge.u(i) .or. w(i).le.0.) go to 90 + 50 continue + if(iopt.ge.0) go to 70 + if(n.lt.nmin .or. n.gt.nest) go to 90 + j = n + do 60 i=1,k1 + t(i) = ub + t(j) = ue + j = j-1 + 60 continue + call fpchec(u,m,t,n,k,ier) + if (ier.eq.0) go to 80 + go to 90 + 70 if(s.lt.0.) go to 90 + if(s.eq.0. .and. nest.lt.(m+k1)) go to 90 + ier = 0 +c we partition the working space and determine the spline curve. + 80 ifp = 1 + iz = ifp+nest + ia = iz+ncc + ib = ia+nest*k1 + ig = ib+nest*k2 + iq = ig+nest*k2 + call fppara(iopt,idim,m,u,mx,x,w,ub,ue,k,s,nest,tol,maxit,k1,k2, + * n,t,ncc,c,fp,wrk(ifp),wrk(iz),wrk(ia),wrk(ib),wrk(ig),wrk(iq), + * iwrk,ier) + 90 return + end diff --git a/fitpack/parder.f b/fitpack/parder.f new file mode 100644 index 0000000..e617042 --- /dev/null +++ b/fitpack/parder.f @@ -0,0 +1,180 @@ + recursive subroutine parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx, + * y,my,z,wrk,lwrk,iwrk,kwrk,ier) + implicit none +c subroutine parder evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,... +c ,my the partial derivative ( order nux,nuy) of a bivariate spline +c s(x,y) of degrees kx and ky, given in the b-spline representation. +c +c calling sequence: +c call parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,wrk,lwrk, +c * iwrk,kwrk,ier) +c +c input parameters: +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c nux : integer values, specifying the order of the partial +c nuy derivative. 0<=nux=1. +c y : real array of dimension (my). +c before entry y(j) must be set to the y co-ordinate of the +c j-th grid point along the y-axis. +c ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my. +c my : on entry my must specify the number of grid points along +c the y-axis. my >=1. +c wrk : real array of dimension lwrk. used as workspace. +c lwrk : integer, specifying the dimension of wrk. +c lwrk >= mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1) +c iwrk : integer array of dimension kwrk. used as workspace. +c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. +c +c output parameters: +c z : real array of dimension (mx*my). +c on successful exit z(my*(i-1)+j) contains the value of the +c specified partial derivative of s(x,y) at the point +c (x(i),y(j)),i=1,...,mx;j=1,...,my. +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c mx >=1, my >=1, 0 <= nux < kx, 0 <= nuy < ky, kwrk>=mx+my +c lwrk>=mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1), +c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx +c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my +c +c other subroutines required: +c fpbisp,fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1989 +c +c ..scalar arguments.. + integer nx,ny,kx,ky,nux,nuy,mx,my,lwrk,kwrk,ier +c ..array arguments.. + integer iwrk(kwrk) + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my), + * wrk(lwrk) +c ..local scalars.. + integer i,iwx,iwy,j,kkx,kky,kx1,ky1,lx,ly,lwest,l1,l2,m,m0,m1, + * nc,nkx1,nky1,nxx,nyy + real*8 ak,fac +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + kx1 = kx+1 + ky1 = ky+1 + nkx1 = nx-kx1 + nky1 = ny-ky1 + nc = nkx1*nky1 + if(nux.lt.0 .or. nux.ge.kx) go to 400 + if(nuy.lt.0 .or. nuy.ge.ky) go to 400 + lwest = nc +(kx1-nux)*mx+(ky1-nuy)*my + if(lwrk.lt.lwest) go to 400 + if(kwrk.lt.(mx+my)) go to 400 + if (mx.lt.1) go to 400 + if (mx.eq.1) go to 30 + go to 10 + 10 do 20 i=2,mx + if(x(i).lt.x(i-1)) go to 400 + 20 continue + 30 if (my.lt.1) go to 400 + if (my.eq.1) go to 60 + go to 40 + 40 do 50 i=2,my + if(y(i).lt.y(i-1)) go to 400 + 50 continue + 60 ier = 0 + nxx = nkx1 + nyy = nky1 + kkx = kx + kky = ky +c the partial derivative of order (nux,nuy) of a bivariate spline of +c degrees kx,ky is a bivariate spline of degrees kx-nux,ky-nuy. +c we calculate the b-spline coefficients of this spline + do 70 i=1,nc + wrk(i) = c(i) + 70 continue + if(nux.eq.0) go to 200 + lx = 1 + do 100 j=1,nux + ak = kkx + nxx = nxx-1 + l1 = lx + m0 = 1 + do 90 i=1,nxx + l1 = l1+1 + l2 = l1+kkx + fac = tx(l2)-tx(l1) + if(fac.le.0.) go to 90 + do 80 m=1,nyy + m1 = m0+nyy + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+1 + 80 continue + 90 continue + lx = lx+1 + kkx = kkx-1 + 100 continue + 200 if(nuy.eq.0) go to 300 + ly = 1 + do 230 j=1,nuy + ak = kky + nyy = nyy-1 + l1 = ly + do 220 i=1,nyy + l1 = l1+1 + l2 = l1+kky + fac = ty(l2)-ty(l1) + if(fac.le.0.) go to 220 + m0 = i + do 210 m=1,nxx + m1 = m0+1 + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+nky1 + 210 continue + 220 continue + ly = ly+1 + kky = kky-1 + 230 continue + m0 = nyy + m1 = nky1 + do 250 m=2,nxx + do 240 i=1,nyy + m0 = m0+1 + m1 = m1+1 + wrk(m0) = wrk(m1) + 240 continue + m1 = m1+nuy + 250 continue +c we partition the working space and evaluate the partial derivative + 300 iwx = 1+nxx*nyy + iwy = iwx+mx*(kx1-nux) + call fpbisp(tx(nux+1),nx-2*nux,ty(nuy+1),ny-2*nuy,wrk,kkx,kky, + * x,mx,y,my,z,wrk(iwx),wrk(iwy),iwrk(1),iwrk(mx+1)) + 400 return + end + diff --git a/fitpack/pardeu.f b/fitpack/pardeu.f new file mode 100644 index 0000000..a2e61ed --- /dev/null +++ b/fitpack/pardeu.f @@ -0,0 +1,159 @@ + recursive subroutine pardeu(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,y,z,m, + * wrk,lwrk,iwrk,kwrk,ier) + implicit none +c subroutine pardeu evaluates on a set of points (x(i),y(i)),i=1,...,m +c the partial derivative ( order nux,nuy) of a bivariate spline +c s(x,y) of degrees kx and ky, given in the b-spline representation. +c +c calling sequence: +c call parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,wrk,lwrk, +c * iwrk,kwrk,ier) +c +c input parameters: +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c nux : integer values, specifying the order of the partial +c nuy derivative. 0<=nux= 1. +c wrk : real array of dimension lwrk. used as workspace. +c lwrk : integer, specifying the dimension of wrk. +c lwrk >= mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1) +c iwrk : integer array of dimension kwrk. used as workspace. +c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. +c +c output parameters: +c z : real array of dimension (m). +c on successful exit z(i) contains the value of the +c specified partial derivative of s(x,y) at the point +c (x(i),y(i)),i=1,...,m. +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c lwrk>=m*(kx+1-nux)+m*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1), +c +c other subroutines required: +c fpbisp,fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1989 +c +c ..scalar arguments.. + integer nx,ny,kx,ky,m,lwrk,kwrk,ier,nux,nuy +c ..array arguments.. + integer iwrk(kwrk) + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(m),y(m),z(m), + * wrk(lwrk) +c ..local scalars.. + integer i,iwx,iwy,j,kkx,kky,kx1,ky1,lx,ly,lwest,l1,l2,mm,m0,m1, + * nc,nkx1,nky1,nxx,nyy + real*8 ak,fac +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + kx1 = kx+1 + ky1 = ky+1 + nkx1 = nx-kx1 + nky1 = ny-ky1 + nc = nkx1*nky1 + if(nux.lt.0 .or. nux.ge.kx) go to 400 + if(nuy.lt.0 .or. nuy.ge.ky) go to 400 + lwest = nc +(kx1-nux)*m+(ky1-nuy)*m + if(lwrk.lt.lwest) go to 400 + if(kwrk.lt.(m+m)) go to 400 + if (m.lt.1) go to 400 + ier = 0 + nxx = nkx1 + nyy = nky1 + kkx = kx + kky = ky +c the partial derivative of order (nux,nuy) of a bivariate spline of +c degrees kx,ky is a bivariate spline of degrees kx-nux,ky-nuy. +c we calculate the b-spline coefficients of this spline + do 70 i=1,nc + wrk(i) = c(i) + 70 continue + if(nux.eq.0) go to 200 + lx = 1 + do 100 j=1,nux + ak = kkx + nxx = nxx-1 + l1 = lx + m0 = 1 + do 90 i=1,nxx + l1 = l1+1 + l2 = l1+kkx + fac = tx(l2)-tx(l1) + if(fac.le.0.) go to 90 + do 80 mm=1,nyy + m1 = m0+nyy + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+1 + 80 continue + 90 continue + lx = lx+1 + kkx = kkx-1 + 100 continue + 200 if(nuy.eq.0) go to 300 + ly = 1 + do 230 j=1,nuy + ak = kky + nyy = nyy-1 + l1 = ly + do 220 i=1,nyy + l1 = l1+1 + l2 = l1+kky + fac = ty(l2)-ty(l1) + if(fac.le.0.) go to 220 + m0 = i + do 210 mm=1,nxx + m1 = m0+1 + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+nky1 + 210 continue + 220 continue + ly = ly+1 + kky = kky-1 + 230 continue + m0 = nyy + m1 = nky1 + do 250 mm=2,nxx + do 240 i=1,nyy + m0 = m0+1 + m1 = m1+1 + wrk(m0) = wrk(m1) + 240 continue + m1 = m1+nuy + 250 continue +c we partition the working space and evaluate the partial derivative + 300 iwx = 1+nxx*nyy + iwy = iwx+m*(kx1-nux) + do 390 i=1,m + call fpbisp(tx(nux+1),nx-2*nux,ty(nuy+1),ny-2*nuy,wrk,kkx,kky, + * x(i),1,y(i),1,z(i),wrk(iwx),wrk(iwy),iwrk(1),iwrk(2)) + 390 continue + 400 return + end diff --git a/fitpack/pardtc.f b/fitpack/pardtc.f new file mode 100644 index 0000000..024caf3 --- /dev/null +++ b/fitpack/pardtc.f @@ -0,0 +1,157 @@ + recursive subroutine pardtc(tx,nx,ty,ny,c,kx,ky,nux,nuy, + * newc,ier) + implicit none +c subroutine pardtc takes the knots and coefficients of a bivariate +c spline, and returns the coefficients for a new bivariate spline that +c evaluates the partial derivative (order nux, nuy) of the original +c spline. +c +c calling sequence: +c call pardtc(tx,nx,ty,ny,c,kx,ky,nux,nuy,newc,ier) +c +c input parameters: +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c (hidden) +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c (hidden) +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c nux : integer values, specifying the order of the partial +c nuy derivative. 0<=nux=0, the number of knots of s(u,v) and their position +c is chosen automatically by the routine. the smoothness of s(u,v) is +c achieved by minimalizing the discontinuity jumps of the derivatives +c of the splines at the knots. the amount of smoothness of s(u,v) is +c determined by the condition that +c fp=sumi=1,mu(sumj=1,mv(dist(f(i,j)-s(u(i),v(j)))**2))<=s, +c with s a given non-negative constant. +c the fit s(u,v) is given in its b-spline representation and can be +c evaluated by means of routine surev. +c +c calling sequence: +c call parsur(iopt,ipar,idim,mu,u,mv,v,f,s,nuest,nvest,nu,tu, +c * nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) +c +c parameters: +c iopt : integer flag. unchanged on exit. +c on entry iopt must specify whether a least-squares surface +c (iopt=-1) or a smoothing surface (iopt=0 or 1)must be +c determined. +c if iopt=0 the routine will start with the initial set of +c knots needed for determining the least-squares polynomial +c surface. +c if iopt=1 the routine will continue with the set of knots +c found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately +c preceded by another call with iopt = 1 or iopt = 0. +c ipar : integer array of dimension 2. unchanged on exit. +c on entry ipar(1) must specify whether (ipar(1)=1) or not +c (ipar(1)=0) the splines must be periodic in the variable u. +c on entry ipar(2) must specify whether (ipar(2)=1) or not +c (ipar(2)=0) the splines must be periodic in the variable v. +c idim : integer. on entry idim must specify the dimension of the +c surface. 1 <= idim <= 3. unchanged on exit. +c mu : integer. on entry mu must specify the number of grid points +c along the u-axis. unchanged on exit. +c mu >= mumin where mumin=4-2*ipar(1) +c u : real array of dimension at least (mu). before entry, u(i) +c must be set to the u-co-ordinate of the i-th grid point +c along the u-axis, for i=1,2,...,mu. these values must be +c supplied in strictly ascending order. unchanged on exit. +c mv : integer. on entry mv must specify the number of grid points +c along the v-axis. unchanged on exit. +c mv >= mvmin where mvmin=4-2*ipar(2) +c v : real array of dimension at least (mv). before entry, v(j) +c must be set to the v-co-ordinate of the j-th grid point +c along the v-axis, for j=1,2,...,mv. these values must be +c supplied in strictly ascending order. unchanged on exit. +c f : real array of dimension at least (mu*mv*idim). +c before entry, f(mu*mv*(l-1)+mv*(i-1)+j) must be set to the +c l-th co-ordinate of the data point corresponding to the +c the grid point (u(i),v(j)) for l=1,...,idim ,i=1,...,mu +c and j=1,...,mv. unchanged on exit. +c if ipar(1)=1 it is expected that f(mu*mv*(l-1)+mv*(mu-1)+j) +c = f(mu*mv*(l-1)+j), l=1,...,idim ; j=1,...,mv +c if ipar(2)=1 it is expected that f(mu*mv*(l-1)+mv*(i-1)+mv) +c = f(mu*mv*(l-1)+mv*(i-1)+1), l=1,...,idim ; i=1,...,mu +c s : real. on entry (if iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments +c nuest : integer. unchanged on exit. +c nvest : integer. unchanged on exit. +c on entry, nuest and nvest must specify an upper bound for the +c number of knots required in the u- and v-directions respect. +c these numbers will also determine the storage space needed by +c the routine. nuest >= 8, nvest >= 8. +c in most practical situation nuest = mu/2, nvest=mv/2, will +c be sufficient. always large enough are nuest=mu+4+2*ipar(1), +c nvest = mv+4+2*ipar(2), the number of knots needed for +c interpolation (s=0). see also further comments. +c nu : integer. +c unless ier=10 (in case iopt>=0), nu will contain the total +c number of knots with respect to the u-variable, of the spline +c surface returned. if the computation mode iopt=1 is used, +c the value of nu should be left unchanged between subsequent +c calls. in case iopt=-1, the value of nu should be specified +c on entry. +c tu : real array of dimension at least (nuest). +c on successful exit, this array will contain the knots of the +c splines with respect to the u-variable, i.e. the position of +c the interior knots tu(5),...,tu(nu-4) as well as the position +c of the additional knots tu(1),...,tu(4) and tu(nu-3),..., +c tu(nu) needed for the b-spline representation. +c if the computation mode iopt=1 is used,the values of tu(1) +c ...,tu(nu) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values tu(5), +c ...tu(nu-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c nv : integer. +c unless ier=10 (in case iopt>=0), nv will contain the total +c number of knots with respect to the v-variable, of the spline +c surface returned. if the computation mode iopt=1 is used, +c the value of nv should be left unchanged between subsequent +c calls. in case iopt=-1, the value of nv should be specified +c on entry. +c tv : real array of dimension at least (nvest). +c on successful exit, this array will contain the knots of the +c splines with respect to the v-variable, i.e. the position of +c the interior knots tv(5),...,tv(nv-4) as well as the position +c of the additional knots tv(1),...,tv(4) and tv(nv-3),..., +c tv(nv) needed for the b-spline representation. +c if the computation mode iopt=1 is used,the values of tv(1) +c ...,tv(nv) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values tv(5), +c ...tv(nv-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c c : real array of dimension at least (nuest-4)*(nvest-4)*idim. +c on successful exit, c contains the coefficients of the spline +c approximation s(u,v) +c fp : real. unless ier=10, fp contains the sum of squared +c residuals of the spline surface returned. +c wrk : real array of dimension (lwrk). used as workspace. +c if the computation mode iopt=1 is used the values of +c wrk(1),...,wrk(4) should be left unchanged between subsequent +c calls. +c lwrk : integer. on entry lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program. +c lwrk must not be too small. +c lwrk >= 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))+ +c 4*(mu+mv)+q*idim where q is the larger of mv and nuest. +c iwrk : integer array of dimension (kwrk). used as workspace. +c if the computation mode iopt=1 is used the values of +c iwrk(1),.,iwrk(3) should be left unchanged between subsequent +c calls. +c kwrk : integer. on entry kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. +c kwrk >= 3+mu+mv+nuest+nvest. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the surface returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline surface returned is an +c interpolating surface (fp=0). +c ier=-2 : normal return. the surface returned is the least-squares +c polynomial surface. in this extreme case fp gives the +c upper bound for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameters nuest and +c nvest. +c probably causes : nuest or nvest too small. if these param- +c eters are already large, it may also indicate that s is +c too small +c the approximation returned is the least-squares surface +c according to the current set of knots. the parameter fp +c gives the corresponding sum of squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing surface with +c fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing surface +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 0<=ipar(1)<=1, 0<=ipar(2)<=1, 1 <=idim<=3 +c mu >= 4-2*ipar(1),mv >= 4-2*ipar(2), nuest >=8, nvest >= 8, +c kwrk>=3+mu+mv+nuest+nvest, +c lwrk >= 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2)) +c +4*(mu+mv)+max(nuest,mv)*idim +c u(i-1)=0: s>=0 +c if s=0: nuest>=mu+4+2*ipar(1) +c nvest>=mv+4+2*ipar(2) +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the surface will be too smooth and signal will be +c lost ; if s is too small the surface will pick up too much noise. in +c the extreme cases the program will return an interpolating surface +c if s=0 and the constrained least-squares polynomial surface if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the accuracy of the data values. +c if the user has an idea of the statistical errors on the data, he +c can also find a proper estimate for s. for, by assuming that, if he +c specifies the right s, parsur will return a surface s(u,v) which +c exactly reproduces the surface underlying the data he can evaluate +c the sum(dist(f(i,j)-s(u(i),v(j)))**2) to find a good estimate for s. +c for example, if he knows that the statistical errors on his f(i,j)- +c values is not greater than 0.1, he may expect that a good s should +c have a value not larger than mu*mv*(0.1)**2. +c if nothing is known about the statistical error in f(i,j), s must +c be determined by trial and error, taking account of the comments +c above. the best is then to start with a very large value of s (to +c determine the le-sq polynomial surface and the corresponding upper +c bound fp0 for s) and then to progressively decrease the value of s +c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... +c and more carefully as the approximation shows more detail) to +c obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt = 1 the program will continue with the knots found at +c the last call of the routine. this will save a lot of computation +c time if parsur is called repeatedly for different values of s. +c the number of knots of the surface returned and their location will +c depend on the value of s and on the complexity of the shape of the +c surface underlying the data. if the computation mode iopt = 1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt=1,the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c parsur once more with the chosen value for s but now with iopt=0. +c indeed, parsur may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c the number of knots may also depend on the upper bounds nuest and +c nvest. indeed, if at a certain stage in parsur the number of knots +c in one direction (say nu) has reached the value of its upper bound +c (nuest), then from that moment on all subsequent knots are added +c in the other (v) direction. this may indicate that the value of +c nuest is too small. on the other hand, it gives the user the option +c of limiting the number of knots the routine locates in any direction +c for example, by setting nuest=8 (the lowest allowable value for +c nuest), the user can indicate that he wants an approximation with +c splines which are simple cubic polynomials in the variable u. +c +c other subroutines required: +c fppasu,fpchec,fpchep,fpknot,fprati,fpgrpa,fptrnp,fpback, +c fpbacp,fpbspl,fptrpe,fpdisc,fpgivs,fprota +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1989 +c +c .. +c ..scalar arguments.. + real*8 s,fp + integer iopt,idim,mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier +c ..array arguments.. + real*8 u(mu),v(mv),f(mu*mv*idim),tu(nuest),tv(nvest), + * c((nuest-4)*(nvest-4)*idim),wrk(lwrk) + integer ipar(2),iwrk(kwrk) +c ..local scalars.. + real*8 tol,ub,ue,vb,ve,peru,perv + integer i,j,jwrk,kndu,kndv,knru,knrv,kwest,l1,l2,l3,l4, + * lfpu,lfpv,lwest,lww,maxit,nc,mf,mumin,mvmin +c ..function references.. + integer max0 +c ..subroutine references.. +c fppasu,fpchec,fpchep +c .. +c we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 200 + if(ipar(1).lt.0 .or. ipar(1).gt.1) go to 200 + if(ipar(2).lt.0 .or. ipar(2).gt.1) go to 200 + if(idim.le.0 .or. idim.gt.3) go to 200 + mumin = 4-2*ipar(1) + if(mu.lt.mumin .or. nuest.lt.8) go to 200 + mvmin = 4-2*ipar(2) + if(mv.lt.mvmin .or. nvest.lt.8) go to 200 + mf = mu*mv + nc = (nuest-4)*(nvest-4) + lwest = 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))+ + * 4*(mu+mv)+max0(nuest,mv)*idim + kwest = 3+mu+mv+nuest+nvest + if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200 + do 10 i=2,mu + if(u(i-1).ge.u(i)) go to 200 + 10 continue + do 20 i=2,mv + if(v(i-1).ge.v(i)) go to 200 + 20 continue + if(iopt.ge.0) go to 100 + if(nu.lt.8 .or. nu.gt.nuest) go to 200 + ub = u(1) + ue = u(mu) + if (ipar(1).ne.0) go to 40 + j = nu + do 30 i=1,4 + tu(i) = ub + tu(j) = ue + j = j-1 + 30 continue + call fpchec(u,mu,tu,nu,3,ier) + if(ier.ne.0) go to 200 + go to 60 + 40 l1 = 4 + l2 = l1 + l3 = nu-3 + l4 = l3 + peru = ue-ub + tu(l2) = ub + tu(l3) = ue + do 50 j=1,3 + l1 = l1+1 + l2 = l2-1 + l3 = l3+1 + l4 = l4-1 + tu(l2) = tu(l4)-peru + tu(l3) = tu(l1)+peru + 50 continue + call fpchep(u,mu,tu,nu,3,ier) + if(ier.ne.0) go to 200 + 60 if(nv.lt.8 .or. nv.gt.nvest) go to 200 + vb = v(1) + ve = v(mv) + if (ipar(2).ne.0) go to 80 + j = nv + do 70 i=1,4 + tv(i) = vb + tv(j) = ve + j = j-1 + 70 continue + call fpchec(v,mv,tv,nv,3,ier) + if(ier.ne.0) go to 200 + go to 150 + 80 l1 = 4 + l2 = l1 + l3 = nv-3 + l4 = l3 + perv = ve-vb + tv(l2) = vb + tv(l3) = ve + do 90 j=1,3 + l1 = l1+1 + l2 = l2-1 + l3 = l3+1 + l4 = l4-1 + tv(l2) = tv(l4)-perv + tv(l3) = tv(l1)+perv + 90 continue + call fpchep(v,mv,tv,nv,3,ier) + if (ier.eq.0) go to 150 + go to 200 + 100 if(s.lt.0.) go to 200 + if(s.eq.0. .and. (nuest.lt.(mu+4+2*ipar(1)) .or. + * nvest.lt.(mv+4+2*ipar(2))) )go to 200 + ier = 0 +c we partition the working space and determine the spline approximation + 150 lfpu = 5 + lfpv = lfpu+nuest + lww = lfpv+nvest + jwrk = lwrk-4-nuest-nvest + knru = 4 + knrv = knru+mu + kndu = knrv+mv + kndv = kndu+nuest + call fppasu(iopt,ipar,idim,u,mu,v,mv,f,mf,s,nuest,nvest, + * tol,maxit,nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4), + * wrk(lfpu),wrk(lfpv),iwrk(1),iwrk(2),iwrk(3),iwrk(knru), + * iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww),jwrk,ier) + 200 return + end + diff --git a/fitpack/percur.f b/fitpack/percur.f new file mode 100644 index 0000000..01d635c --- /dev/null +++ b/fitpack/percur.f @@ -0,0 +1,275 @@ + recursive subroutine percur(iopt,m,x,y,w,k,s,nest,n,t,c,fp, + * wrk,lwrk,iwrk,ier) + implicit none +c given the set of data points (x(i),y(i)) and the set of positive +c numbers w(i),i=1,2,...,m-1, subroutine percur determines a smooth +c periodic spline approximation of degree k with period per=x(m)-x(1). +c if iopt=-1 percur calculates the weighted least-squares periodic +c spline according to a given set of knots. +c if iopt>=0 the number of knots of the spline s(x) and the position +c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- +c ness of s(x) is then achieved by minimalizing the discontinuity +c jumps of the k-th derivative of s(x) at the knots t(j),j=k+2,k+3,..., +c n-k-1. the amount of smoothness is determined by the condition that +c f(p)=sum((w(i)*(y(i)-s(x(i))))**2) be <= s, with s a given non- +c negative constant, called the smoothing factor. +c the fit s(x) is given in the b-spline representation (b-spline coef- +c ficients c(j),j=1,2,...,n-k-1) and can be evaluated by means of +c subroutine splev. +c +c calling sequence: +c call percur(iopt,m,x,y,w,k,s,nest,n,t,c,fp,wrk, +c * lwrk,iwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a weighted +c least-squares spline (iopt=-1) or a smoothing spline (iopt= +c 0 or 1) must be determined. if iopt=0 the routine will start +c with an initial set of knots t(i)=x(1)+(x(m)-x(1))*(i-k-1), +c i=1,2,...,2*k+2. if iopt=1 the routine will continue with +c the knots found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately +c preceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m > 1. unchanged on exit. +c x : real array of dimension at least (m). before entry, x(i) +c must be set to the i-th value of the independent variable x, +c for i=1,2,...,m. these values must be supplied in strictly +c ascending order. x(m) only indicates the length of the +c period of the spline, i.e per=x(m)-x(1). +c unchanged on exit. +c y : real array of dimension at least (m). before entry, y(i) +c must be set to the i-th value of the dependent variable y, +c for i=1,2,...,m-1. the element y(m) is not used. +c unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) +c must be set to the i-th value in the set of weights. the +c w(i) must be strictly positive. w(m) is not used. +c see also further comments. unchanged on exit. +c k : integer. on entry k must specify the degree of the spline. +c 1<=k<=5. it is recommended to use cubic splines (k=3). +c the user is strongly dissuaded from choosing k even,together +c with a small s-value. unchanged on exit. +c s : real.on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments. +c nest : integer. on entry nest must contain an over-estimate of the +c total number of knots of the spline returned, to indicate +c the storage space available to the routine. nest >=2*k+2. +c in most practical situation nest=m/2 will be sufficient. +c always large enough is nest=m+2*k,the number of knots needed +c for interpolation (s=0). unchanged on exit. +c n : integer. +c unless ier = 10 (in case iopt >=0), n will contain the +c total number of knots of the spline approximation returned. +c if the computation mode iopt=1 is used this value of n +c should be left unchanged between subsequent calls. +c in case iopt=-1, the value of n must be specified on entry. +c t : real array of dimension at least (nest). +c on successful exit, this array will contain the knots of the +c spline,i.e. the position of the interior knots t(k+2),t(k+3) +c ...,t(n-k-1) as well as the position of the additional knots +c t(1),t(2),...,t(k+1)=x(1) and t(n-k)=x(m),..,t(n) needed for +c the b-spline representation. +c if the computation mode iopt=1 is used, the values of t(1), +c t(2),...,t(n) should be left unchanged between subsequent +c calls. if the computation mode iopt=-1 is used, the values +c t(k+2),...,t(n-k-1) must be supplied by the user, before +c entry. see also the restrictions (ier=10). +c c : real array of dimension at least (nest). +c on successful exit, this array will contain the coefficients +c c(1),c(2),..,c(n-k-1) in the b-spline representation of s(x) +c fp : real. unless ier = 10, fp contains the weighted sum of +c squared residuals of the spline approximation returned. +c wrk : real array of dimension at least (m*(k+1)+nest*(8+5*k)). +c used as working space. if the computation mode iopt=1 is +c used, the values wrk(1),...,wrk(n) should be left unchanged +c between subsequent calls. +c lwrk : integer. on entry,lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program. lwrk +c must not be too small (see wrk). unchanged on exit. +c iwrk : integer array of dimension at least (nest). +c used as working space. if the computation mode iopt=1 is +c used,the values iwrk(1),...,iwrk(n) should be left unchanged +c between subsequent calls. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c periodic spline (fp=0). +c ier=-2 : normal return. the spline returned is the weighted least- +c squares constant. in this extreme case fp gives the upper +c bound fp0 for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameter nest. +c probably causes : nest too small. if nest is already +c large (say nest > m/2), it may also indicate that s is +c too small +c the approximation returned is the least-squares periodic +c spline according to the knots t(1),t(2),...,t(n). (n=nest) +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline with +c fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 1<=k<=5, m>1, nest>2*k+2, w(i)>0,i=1,...,m-1 +c x(1)=(k+1)*m+nest*(8+5*k) +c if iopt=-1: 2*k+2<=n<=min(nest,m+2*k) +c x(1)=0: s>=0 +c if s=0 : nest >= m+2*k +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating periodic +c spline if s=0 and the weighted least-squares constant if s is very +c large. between these extremes, a properly chosen s will result in +c a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c y(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in y(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the least-squares +c constant and the corresponding upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximation shows more detail) to obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if percur is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. but, if the computation mode iopt=1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c percur once more with the selected value for s but now with iopt=0. +c indeed, percur may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c +c other subroutines required: +c fpbacp,fpbspl,fpchep,fpperi,fpdisc,fpgivs,fpknot,fprati,fprota +c +c references: +c dierckx p. : algorithms for smoothing data with periodic and +c parametric splines, computer graphics and image +c processing 20 (1982) 171-184. +c dierckx p. : algorithms for smoothing data with periodic and param- +c etric splines, report tw55, dept. computer science, +c k.u.leuven, 1981. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + real*8 s,fp + integer iopt,m,k,nest,n,lwrk,ier +c ..array arguments.. + real*8 x(m),y(m),w(m),t(nest),c(nest),wrk(lwrk) + integer iwrk(nest) +c ..local scalars.. + real*8 per,tol + integer i,ia1,ia2,ib,ifp,ig1,ig2,iq,iz,i1,i2,j1,j2,k1,k2,lwest, + * maxit,m1,nmin +c ..subroutine references.. +c perper,pcheck +c .. +c we set up the parameters tol and maxit + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(k.le.0 .or. k.gt.5) go to 50 + k1 = k+1 + k2 = k1+1 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 50 + nmin = 2*k1 + if(m.lt.2 .or. nest.lt.nmin) go to 50 + lwest = m*k1+nest*(8+5*k) + if(lwrk.lt.lwest) go to 50 + m1 = m-1 + do 10 i=1,m1 + if(x(i).ge.x(i+1) .or. w(i).le.0.) go to 50 + 10 continue + if(iopt.ge.0) go to 30 + if(n.le.nmin .or. n.gt.nest) go to 50 + per = x(m)-x(1) + j1 = k1 + t(j1) = x(1) + i1 = n-k + t(i1) = x(m) + j2 = j1 + i2 = i1 + do 20 i=1,k + i1 = i1+1 + i2 = i2-1 + j1 = j1+1 + j2 = j2-1 + t(j2) = t(i2)-per + t(i1) = t(j1)+per + 20 continue + call fpchep(x,m,t,n,k,ier) + if (ier.eq.0) go to 40 + go to 50 + 30 if(s.lt.0.) go to 50 + if(s.eq.0. .and. nest.lt.(m+2*k)) go to 50 + ier = 0 +c we partition the working space and determine the spline approximation. + 40 ifp = 1 + iz = ifp+nest + ia1 = iz+nest + ia2 = ia1+nest*k1 + ib = ia2+nest*k + ig1 = ib+nest*k2 + ig2 = ig1+nest*k2 + iq = ig2+nest*k1 + call fpperi(iopt,x,y,w,m,k,s,nest,tol,maxit,k1,k2,n,t,c,fp, + * wrk(ifp),wrk(iz),wrk(ia1),wrk(ia2),wrk(ib),wrk(ig1),wrk(ig2), + * wrk(iq),iwrk,ier) + 50 return + end diff --git a/fitpack/pogrid.f b/fitpack/pogrid.f new file mode 100644 index 0000000..8ffa44a --- /dev/null +++ b/fitpack/pogrid.f @@ -0,0 +1,467 @@ + recursive subroutine pogrid(iopt,ider,mu,u,mv,v,z,z0,r,s, + * nuest,nvest,nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) + implicit none +c subroutine pogrid fits a function f(x,y) to a set of data points +c z(i,j) given at the nodes (x,y)=(u(i)*cos(v(j)),u(i)*sin(v(j))), +c i=1,...,mu ; j=1,...,mv , of a radius-angle grid over a disc +c x ** 2 + y ** 2 <= r ** 2 . +c +c this approximation problem is reduced to the determination of a +c bicubic spline s(u,v) smoothing the data (u(i),v(j),z(i,j)) on the +c rectangle 0<=u<=r, v(1)<=v<=v(1)+2*pi +c in order to have continuous partial derivatives +c i+j +c d f(0,0) +c g(i,j) = ---------- +c i j +c dx dy +c +c s(u,v)=f(x,y) must satisfy the following conditions +c +c (1) s(0,v) = g(0,0) v(1)<=v<= v(1)+2*pi +c +c d s(0,v) +c (2) -------- = cos(v)*g(1,0)+sin(v)*g(0,1) v(1)<=v<= v(1)+2*pi +c d u +c +c moreover, s(u,v) must be periodic in the variable v, i.e. +c +c j j +c d s(u,vb) d s(u,ve) +c (3) ---------- = --------- 0 <=u<= r, j=0,1,2 , vb=v(1), +c j j ve=vb+2*pi +c d v d v +c +c the number of knots of s(u,v) and their position tu(i),i=1,2,...,nu; +c tv(j),j=1,2,...,nv, is chosen automatically by the routine. the +c smoothness of s(u,v) is achieved by minimalizing the discontinuity +c jumps of the derivatives of the spline at the knots. the amount of +c smoothness of s(u,v) is determined by the condition that +c fp=sumi=1,mu(sumj=1,mv((z(i,j)-s(u(i),v(j)))**2))+(z0-g(0,0))**2<=s, +c with s a given non-negative constant. +c the fit s(u,v) is given in its b-spline representation and can be +c evaluated by means of routine bispev. f(x,y) = s(u,v) can also be +c evaluated by means of function program evapol. +c +c calling sequence: +c call pogrid(iopt,ider,mu,u,mv,v,z,z0,r,s,nuest,nvest,nu,tu, +c * ,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) +c +c parameters: +c iopt : integer array of dimension 3, specifying different options. +c unchanged on exit. +c iopt(1):on entry iopt(1) must specify whether a least-squares spline +c (iopt(1)=-1) or a smoothing spline (iopt(1)=0 or 1) must be +c determined. +c if iopt(1)=0 the routine will start with an initial set of +c knots tu(i)=0,tu(i+4)=r,i=1,...,4;tv(i)=v(1)+(i-4)*2*pi,i=1,. +c ...,8. +c if iopt(1)=1 the routine will continue with the set of knots +c found at the last call of the routine. +c attention: a call with iopt(1)=1 must always be immediately +c preceded by another call with iopt(1) = 1 or iopt(1) = 0. +c iopt(2):on entry iopt(2) must specify the requested order of conti- +c nuity for f(x,y) at the origin. +c if iopt(2)=0 only condition (1) must be fulfilled and +c if iopt(2)=1 conditions (1)+(2) must be fulfilled. +c iopt(3):on entry iopt(3) must specify whether (iopt(3)=1) or not +c (iopt(3)=0) the approximation f(x,y) must vanish at the +c boundary of the approximation domain. +c ider : integer array of dimension 2, specifying different options. +c unchanged on exit. +c ider(1):on entry ider(1) must specify whether (ider(1)=0 or 1) or not +c (ider(1)=-1) there is a data value z0 at the origin. +c if ider(1)=1, z0 will be considered to be the right function +c value, and it will be fitted exactly (g(0,0)=z0=c(1)). +c if ider(1)=0, z0 will be considered to be a data value just +c like the other data values z(i,j). +c ider(2):on entry ider(2) must specify whether (ider(2)=1) or not +c (ider(2)=0) f(x,y) must have vanishing partial derivatives +c g(1,0) and g(0,1) at the origin. (in case iopt(2)=1) +c mu : integer. on entry mu must specify the number of grid points +c along the u-axis. unchanged on exit. +c mu >= mumin where mumin=4-iopt(3)-ider(2) if ider(1)<0 +c =3-iopt(3)-ider(2) if ider(1)>=0 +c u : real array of dimension at least (mu). before entry, u(i) +c must be set to the u-co-ordinate of the i-th grid point +c along the u-axis, for i=1,2,...,mu. these values must be +c positive and supplied in strictly ascending order. +c unchanged on exit. +c mv : integer. on entry mv must specify the number of grid points +c along the v-axis. mv > 3 . unchanged on exit. +c v : real array of dimension at least (mv). before entry, v(j) +c must be set to the v-co-ordinate of the j-th grid point +c along the v-axis, for j=1,2,...,mv. these values must be +c supplied in strictly ascending order. unchanged on exit. +c -pi <= v(1) < pi , v(mv) < v(1)+2*pi. +c z : real array of dimension at least (mu*mv). +c before entry, z(mv*(i-1)+j) must be set to the data value at +c the grid point (u(i),v(j)) for i=1,...,mu and j=1,...,mv. +c unchanged on exit. +c z0 : real value. on entry (if ider(1) >=0 ) z0 must specify the +c data value at the origin. unchanged on exit. +c r : real value. on entry r must specify the radius of the disk. +c r>=u(mu) (>u(mu) if iopt(3)=1). unchanged on exit. +c s : real. on entry (if iopt(1)>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments +c nuest : integer. unchanged on exit. +c nvest : integer. unchanged on exit. +c on entry, nuest and nvest must specify an upper bound for the +c number of knots required in the u- and v-directions respect. +c these numbers will also determine the storage space needed by +c the routine. nuest >= 8, nvest >= 8. +c in most practical situation nuest = mu/2, nvest=mv/2, will +c be sufficient. always large enough are nuest=mu+5+iopt(2)+ +c iopt(3), nvest = mv+7, the number of knots needed for +c interpolation (s=0). see also further comments. +c nu : integer. +c unless ier=10 (in case iopt(1)>=0), nu will contain the total +c number of knots with respect to the u-variable, of the spline +c approximation returned. if the computation mode iopt(1)=1 is +c used, the value of nu should be left unchanged between sub- +c sequent calls. in case iopt(1)=-1, the value of nu should be +c specified on entry. +c tu : real array of dimension at least (nuest). +c on successful exit, this array will contain the knots of the +c spline with respect to the u-variable, i.e. the position of +c the interior knots tu(5),...,tu(nu-4) as well as the position +c of the additional knots tu(1)=...=tu(4)=0 and tu(nu-3)=...= +c tu(nu)=r needed for the b-spline representation. +c if the computation mode iopt(1)=1 is used,the values of tu(1) +c ...,tu(nu) should be left unchanged between subsequent calls. +c if the computation mode iopt(1)=-1 is used, the values tu(5), +c ...tu(nu-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c nv : integer. +c unless ier=10 (in case iopt(1)>=0), nv will contain the total +c number of knots with respect to the v-variable, of the spline +c approximation returned. if the computation mode iopt(1)=1 is +c used, the value of nv should be left unchanged between sub- +c sequent calls. in case iopt(1) = -1, the value of nv should +c be specified on entry. +c tv : real array of dimension at least (nvest). +c on successful exit, this array will contain the knots of the +c spline with respect to the v-variable, i.e. the position of +c the interior knots tv(5),...,tv(nv-4) as well as the position +c of the additional knots tv(1),...,tv(4) and tv(nv-3),..., +c tv(nv) needed for the b-spline representation. +c if the computation mode iopt(1)=1 is used,the values of tv(1) +c ...,tv(nv) should be left unchanged between subsequent calls. +c if the computation mode iopt(1)=-1 is used, the values tv(5), +c ...tv(nv-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c c : real array of dimension at least (nuest-4)*(nvest-4). +c on successful exit, c contains the coefficients of the spline +c approximation s(u,v) +c fp : real. unless ier=10, fp contains the sum of squared +c residuals of the spline approximation returned. +c wrk : real array of dimension (lwrk). used as workspace. +c if the computation mode iopt(1)=1 is used the values of +c wrk(1),...,wrk(8) should be left unchanged between subsequent +c calls. +c lwrk : integer. on entry lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program. +c lwrk must not be too small. +c lwrk >= 8+nuest*(mv+nvest+3)+nvest*21+4*mu+6*mv+q +c where q is the larger of (mv+nvest) and nuest. +c iwrk : integer array of dimension (kwrk). used as workspace. +c if the computation mode iopt(1)=1 is used the values of +c iwrk(1),.,iwrk(4) should be left unchanged between subsequent +c calls. +c kwrk : integer. on entry kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. +c kwrk >= 4+mu+mv+nuest+nvest. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c spline (fp=0). +c ier=-2 : normal return. the spline returned is the least-squares +c constrained polynomial. in this extreme case fp gives the +c upper bound for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameters nuest and +c nvest. +c probably causes : nuest or nvest too small. if these param- +c eters are already large, it may also indicate that s is +c too small +c the approximation returned is the least-squares spline +c according to the current set of knots. the parameter fp +c gives the corresponding sum of squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline with +c fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt(1)<=1, 0<=iopt(2)<=1, 0<=iopt(3)<=1, +c -1<=ider(1)<=1, 0<=ider(2)<=1, ider(2)=0 if iopt(2)=0. +c mu >= mumin (see above), mv >= 4, nuest >=8, nvest >= 8, +c kwrk>=4+mu+mv+nuest+nvest, +c lwrk >= 8+nuest*(mv+nvest+3)+nvest*21+4*mu+6*mv+ +c max(nuest,mv+nvest) +c 0< u(i-1)=0: s>=0 +c if s=0: nuest>=mu+5+iopt(2)+iopt(3), nvest>=mv+7 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c pogrid does not allow individual weighting of the data-values. +c so, if these were determined to widely different accuracies, then +c perhaps the general data set routine polar should rather be used +c in spite of efficiency. +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the constrained least-squares polynomial(degrees 3,0)if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the accuracy of the data values. +c if the user has an idea of the statistical errors on the data, he +c can also find a proper estimate for s. for, by assuming that, if he +c specifies the right s, pogrid will return a spline s(u,v) which +c exactly reproduces the function underlying the data he can evaluate +c the sum((z(i,j)-s(u(i),v(j)))**2) to find a good estimate for this s +c for example, if he knows that the statistical errors on his z(i,j)- +c values is not greater than 0.1, he may expect that a good s should +c have a value not larger than mu*mv*(0.1)**2. +c if nothing is known about the statistical error in z(i,j), s must +c be determined by trial and error, taking account of the comments +c above. the best is then to start with a very large value of s (to +c determine the least-squares polynomial and the corresponding upper +c bound fp0 for s) and then to progressively decrease the value of s +c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... +c and more carefully as the approximation shows more detail) to +c obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt(1)=0. +c if iopt(1) = 1 the program will continue with the knots found at +c the last call of the routine. this will save a lot of computation +c time if pogrid is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. if the computation mode iopt(1) = 1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt(1)=1,the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c pogrid once more with the chosen value for s but now with iopt(1)=0. +c indeed, pogrid may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c the number of knots may also depend on the upper bounds nuest and +c nvest. indeed, if at a certain stage in pogrid the number of knots +c in one direction (say nu) has reached the value of its upper bound +c (nuest), then from that moment on all subsequent knots are added +c in the other (v) direction. this may indicate that the value of +c nuest is too small. on the other hand, it gives the user the option +c of limiting the number of knots the routine locates in any direction +c for example, by setting nuest=8 (the lowest allowable value for +c nuest), the user can indicate that he wants an approximation which +c is a simple cubic polynomial in the variable u. +c +c other subroutines required: +c fppogr,fpchec,fpchep,fpknot,fpopdi,fprati,fpgrdi,fpsysy,fpback, +c fpbacp,fpbspl,fpcyt1,fpcyt2,fpdisc,fpgivs,fprota +c +c references: +c dierckx p. : fast algorithms for smoothing data over a disc or a +c sphere using tensor product splines, in "algorithms +c for approximation", ed. j.c.mason and m.g.cox, +c clarendon press oxford, 1987, pp. 51-65 +c dierckx p. : fast algorithms for smoothing data over a disc or a +c sphere using tensor product splines, report tw73, dept. +c computer science,k.u.leuven, 1985. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : july 1985 +c latest update : march 1989 +c +c .. +c ..scalar arguments.. + real*8 z0,r,s,fp + integer mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier +c ..array arguments.. + integer iopt(3),ider(2),iwrk(kwrk) + real*8 u(mu),v(mv),z(mu*mv),c((nuest-4)*(nvest-4)),tu(nuest), + * tv(nvest),wrk(lwrk) +c ..local scalars.. + real*8 per,pi,tol,uu,ve,zmax,zmin,one,half,rn,zb + integer i,i1,i2,j,jwrk,j1,j2,kndu,kndv,knru,knrv,kwest,l, + * ldz,lfpu,lfpv,lwest,lww,m,maxit,mumin,muu,nc +c ..function references.. + real*8 datan2 + integer max0 +c ..subroutine references.. +c fpchec,fpchep,fppogr +c .. +c set constants + one = 1d0 + half = 0.5e0 + pi = datan2(0d0,-one) + per = pi+pi + ve = v(1)+per +c we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1e-02 +c before starting computations, a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(iopt(1).lt.(-1) .or. iopt(1).gt.1) go to 200 + if(iopt(2).lt.0 .or. iopt(2).gt.1) go to 200 + if(iopt(3).lt.0 .or. iopt(3).gt.1) go to 200 + if(ider(1).lt.(-1) .or. ider(1).gt.1) go to 200 + if(ider(2).lt.0 .or. ider(2).gt.1) go to 200 + if(ider(2).eq.1 .and. iopt(2).eq.0) go to 200 + mumin = 4-iopt(3)-ider(2) + if(ider(1).ge.0) mumin = mumin-1 + if(mu.lt.mumin .or. mv.lt.4) go to 200 + if(nuest.lt.8 .or. nvest.lt.8) go to 200 + m = mu*mv + nc = (nuest-4)*(nvest-4) + lwest = 8+nuest*(mv+nvest+3)+21*nvest+4*mu+6*mv+ + * max0(nuest,mv+nvest) + kwest = 4+mu+mv+nuest+nvest + if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200 + if(u(1).le.0. .or. u(mu).gt.r) go to 200 + if(iopt(3).eq.0) go to 10 + if(u(mu).eq.r) go to 200 + 10 if(mu.eq.1) go to 30 + do 20 i=2,mu + if(u(i-1).ge.u(i)) go to 200 + 20 continue + 30 if(v(1).lt. (-pi) .or. v(1).ge.pi ) go to 200 + if(v(mv).ge.v(1)+per) go to 200 + do 40 i=2,mv + if(v(i-1).ge.v(i)) go to 200 + 40 continue + if(iopt(1).gt.0) go to 140 +c if not given, we compute an estimate for z0. + if(ider(1).lt.0) go to 50 + zb = z0 + go to 70 + 50 zb = 0. + do 60 i=1,mv + zb = zb+z(i) + 60 continue + rn = mv + zb = zb/rn +c we determine the range of z-values. + 70 zmin = zb + zmax = zb + do 80 i=1,m + if(z(i).lt.zmin) zmin = z(i) + if(z(i).gt.zmax) zmax = z(i) + 80 continue + wrk(5) = zb + wrk(6) = 0. + wrk(7) = 0. + wrk(8) = zmax -zmin + iwrk(4) = mu + if(iopt(1).eq.0) go to 140 + if(nu.lt.8 .or. nu.gt.nuest) go to 200 + if(nv.lt.11 .or. nv.gt.nvest) go to 200 + j = nu + do 90 i=1,4 + tu(i) = 0. + tu(j) = r + j = j-1 + 90 continue + l = 9 + wrk(l) = 0. + if(iopt(2).eq.0) go to 100 + l = l+1 + uu = u(1) + if(uu.gt.tu(5)) uu = tu(5) + wrk(l) = uu*half + 100 do 110 i=1,mu + l = l+1 + wrk(l) = u(i) + 110 continue + if(iopt(3).eq.0) go to 120 + l = l+1 + wrk(l) = r + 120 muu = l-8 + call fpchec(wrk(9),muu,tu,nu,3,ier) + if(ier.ne.0) go to 200 + j1 = 4 + tv(j1) = v(1) + i1 = nv-3 + tv(i1) = ve + j2 = j1 + i2 = i1 + do 130 i=1,3 + i1 = i1+1 + i2 = i2-1 + j1 = j1+1 + j2 = j2-1 + tv(j2) = tv(i2)-per + tv(i1) = tv(j1)+per + 130 continue + l = 9 + do 135 i=1,mv + wrk(l) = v(i) + l = l+1 + 135 continue + wrk(l) = ve + call fpchep(wrk(9),mv+1,tv,nv,3,ier) + if (ier.eq.0) go to 150 + go to 200 + 140 if(s.lt.0.) go to 200 + if(s.eq.0. .and. (nuest.lt.(mu+5+iopt(2)+iopt(3)) .or. + * nvest.lt.(mv+7)) ) go to 200 +c we partition the working space and determine the spline approximation + 150 ldz = 5 + lfpu = 9 + lfpv = lfpu+nuest + lww = lfpv+nvest + jwrk = lwrk-8-nuest-nvest + knru = 5 + knrv = knru+mu + kndu = knrv+mv + kndv = kndu+nuest + call fppogr(iopt,ider,u,mu,v,mv,z,m,zb,r,s,nuest,nvest,tol,maxit, + * nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),wrk(lfpu), + * wrk(lfpv),wrk(ldz),wrk(8),iwrk(1),iwrk(2),iwrk(3),iwrk(4), + * iwrk(knru),iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww),jwrk,ier) + 200 return + end + diff --git a/fitpack/polar.f b/fitpack/polar.f new file mode 100644 index 0000000..3b78848 --- /dev/null +++ b/fitpack/polar.f @@ -0,0 +1,451 @@ + recursive subroutine polar(iopt,m,x,y,z,w,rad,s,nuest,nvest, + * eps,nu,tu,nv,tv,u,v,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) + implicit none +c subroutine polar fits a smooth function f(x,y) to a set of data +c points (x(i),y(i),z(i)) scattered arbitrarily over an approximation +c domain x**2+y**2 <= rad(atan(y/x))**2. through the transformation +c x = u*rad(v)*cos(v) , y = u*rad(v)*sin(v) +c the approximation problem is reduced to the determination of a bi- +c cubic spline s(u,v) fitting a corresponding set of data points +c (u(i),v(i),z(i)) on the rectangle 0<=u<=1,-pi<=v<=pi. +c in order to have continuous partial derivatives +c i+j +c d f(0,0) +c g(i,j) = ---------- +c i j +c dx dy +c +c s(u,v)=f(x,y) must satisfy the following conditions +c +c (1) s(0,v) = g(0,0) -pi <=v<= pi. +c +c d s(0,v) +c (2) -------- = rad(v)*(cos(v)*g(1,0)+sin(v)*g(0,1)) +c d u +c -pi <=v<= pi +c 2 +c d s(0,v) 2 2 2 +c (3) -------- = rad(v)*(cos(v)*g(2,0)+sin(v)*g(0,2)+sin(2*v)*g(1,1)) +c 2 +c d u -pi <=v<= pi +c +c moreover, s(u,v) must be periodic in the variable v, i.e. +c +c j j +c d s(u,-pi) d s(u,pi) +c (4) ---------- = --------- 0 <=u<= 1, j=0,1,2 +c j j +c d v d v +c +c if iopt(1) < 0 circle calculates a weighted least-squares spline +c according to a given set of knots in u- and v- direction. +c if iopt(1) >=0, the number of knots in each direction and their pos- +c ition tu(j),j=1,2,...,nu ; tv(j),j=1,2,...,nv are chosen automatical- +c ly by the routine. the smoothness of s(u,v) is then achieved by mini- +c malizing the discontinuity jumps of the derivatives of the spline +c at the knots. the amount of smoothness of s(u,v) is determined by +c the condition that fp = sum((w(i)*(z(i)-s(u(i),v(i))))**2) be <= s, +c with s a given non-negative constant. +c the bicubic spline is given in its standard b-spline representation +c and the corresponding function f(x,y) can be evaluated by means of +c function program evapol. +c +c calling sequence: +c call polar(iopt,m,x,y,z,w,rad,s,nuest,nvest,eps,nu,tu, +c * nv,tv,u,v,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) +c +c parameters: +c iopt : integer array of dimension 3, specifying different options. +c unchanged on exit. +c iopt(1):on entry iopt(1) must specify whether a weighted +c least-squares polar spline (iopt(1)=-1) or a smoothing +c polar spline (iopt(1)=0 or 1) must be determined. +c if iopt(1)=0 the routine will start with an initial set of +c knots tu(i)=0,tu(i+4)=1,i=1,...,4;tv(i)=(2*i-9)*pi,i=1,...,8. +c if iopt(1)=1 the routine will continue with the set of knots +c found at the last call of the routine. +c attention: a call with iopt(1)=1 must always be immediately +c preceded by another call with iopt(1) = 1 or iopt(1) = 0. +c iopt(2):on entry iopt(2) must specify the requested order of conti- +c nuity for f(x,y) at the origin. +c if iopt(2)=0 only condition (1) must be fulfilled, +c if iopt(2)=1 conditions (1)+(2) must be fulfilled and +c if iopt(2)=2 conditions (1)+(2)+(3) must be fulfilled. +c iopt(3):on entry iopt(3) must specify whether (iopt(3)=1) or not +c (iopt(3)=0) the approximation f(x,y) must vanish at the +c boundary of the approximation domain. +c m : integer. on entry m must specify the number of data points. +c m >= 4-iopt(2)-iopt(3) unchanged on exit. +c x : real array of dimension at least (m). +c y : real array of dimension at least (m). +c z : real array of dimension at least (m). +c before entry, x(i),y(i),z(i) must be set to the co-ordinates +c of the i-th data point, for i=1,...,m. the order of the data +c points is immaterial. unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) must +c be set to the i-th value in the set of weights. the w(i) must +c be strictly positive. unchanged on exit. +c rad : real function subprogram defining the boundary of the approx- +c imation domain, i.e x = rad(v)*cos(v) , y = rad(v)*sin(v), +c -pi <= v <= pi. +c must be declared external in the calling (sub)program. +c s : real. on entry (in case iopt(1) >=0) s must specify the +c smoothing factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments +c nuest : integer. unchanged on exit. +c nvest : integer. unchanged on exit. +c on entry, nuest and nvest must specify an upper bound for the +c number of knots required in the u- and v-directions resp. +c these numbers will also determine the storage space needed by +c the routine. nuest >= 8, nvest >= 8. +c in most practical situation nuest = nvest = 8+sqrt(m/2) will +c be sufficient. see also further comments. +c eps : real. +c on entry, eps must specify a threshold for determining the +c effective rank of an over-determined linear system of equat- +c ions. 0 < eps < 1. if the number of decimal digits in the +c computer representation of a real number is q, then 10**(-q) +c is a suitable value for eps in most practical applications. +c unchanged on exit. +c nu : integer. +c unless ier=10 (in case iopt(1) >=0),nu will contain the total +c number of knots with respect to the u-variable, of the spline +c approximation returned. if the computation mode iopt(1)=1 +c is used, the value of nu should be left unchanged between +c subsequent calls. +c in case iopt(1)=-1,the value of nu must be specified on entry +c tu : real array of dimension at least nuest. +c on successful exit, this array will contain the knots of the +c spline with respect to the u-variable, i.e. the position +c of the interior knots tu(5),...,tu(nu-4) as well as the +c position of the additional knots tu(1)=...=tu(4)=0 and +c tu(nu-3)=...=tu(nu)=1 needed for the b-spline representation +c if the computation mode iopt(1)=1 is used,the values of +c tu(1),...,tu(nu) should be left unchanged between subsequent +c calls. if the computation mode iopt(1)=-1 is used,the values +c tu(5),...tu(nu-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c nv : integer. +c unless ier=10 (in case iopt(1)>=0), nv will contain the total +c number of knots with respect to the v-variable, of the spline +c approximation returned. if the computation mode iopt(1)=1 +c is used, the value of nv should be left unchanged between +c subsequent calls. in case iopt(1)=-1, the value of nv should +c be specified on entry. +c tv : real array of dimension at least nvest. +c on successful exit, this array will contain the knots of the +c spline with respect to the v-variable, i.e. the position of +c the interior knots tv(5),...,tv(nv-4) as well as the position +c of the additional knots tv(1),...,tv(4) and tv(nv-3),..., +c tv(nv) needed for the b-spline representation. +c if the computation mode iopt(1)=1 is used, the values of +c tv(1),...,tv(nv) should be left unchanged between subsequent +c calls. if the computation mode iopt(1)=-1 is used,the values +c tv(5),...tv(nv-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c u : real array of dimension at least (m). +c v : real array of dimension at least (m). +c on successful exit, u(i),v(i) contains the co-ordinates of +c the i-th data point with respect to the transformed rectan- +c gular approximation domain, for i=1,2,...,m. +c if the computation mode iopt(1)=1 is used the values of +c u(i),v(i) should be left unchanged between subsequent calls. +c c : real array of dimension at least (nuest-4)*(nvest-4). +c on successful exit, c contains the coefficients of the spline +c approximation s(u,v). +c fp : real. unless ier=10, fp contains the weighted sum of +c squared residuals of the spline approximation returned. +c wrk1 : real array of dimension (lwrk1). used as workspace. +c if the computation mode iopt(1)=1 is used the value of +c wrk1(1) should be left unchanged between subsequent calls. +c on exit wrk1(2),wrk1(3),...,wrk1(1+ncof) will contain the +c values d(i)/max(d(i)),i=1,...,ncof=1+iopt(2)*(iopt(2)+3)/2+ +c (nv-7)*(nu-5-iopt(2)-iopt(3)) with d(i) the i-th diagonal el- +c ement of the triangular matrix for calculating the b-spline +c coefficients.it includes those elements whose square is < eps +c which are treated as 0 in the case of rank deficiency(ier=-2) +c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of +c the array wrk1 as declared in the calling (sub)program. +c lwrk1 must not be too small. let +c k = nuest-7, l = nvest-7, p = 1+iopt(2)*(iopt(2)+3)/2, +c q = k+2-iopt(2)-iopt(3) then +c lwrk1 >= 129+10*k+21*l+k*l+(p+l*q)*(1+8*l+p)+8*m +c wrk2 : real array of dimension (lwrk2). used as workspace, but +c only in the case a rank deficient system is encountered. +c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of +c the array wrk2 as declared in the calling (sub)program. +c lwrk2 > 0 . a save upper bound for lwrk2 = (p+l*q+1)*(4*l+p) +c +p+l*q where p,l,q are as above. if there are enough data +c points, scattered uniformly over the approximation domain +c and if the smoothing factor s is not too small, there is a +c good chance that this extra workspace is not needed. a lot +c of memory might therefore be saved by setting lwrk2=1. +c (see also ier > 10) +c iwrk : integer array of dimension (kwrk). used as workspace. +c kwrk : integer. on entry kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. +c kwrk >= m+(nuest-7)*(nvest-7). +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c spline (fp=0). +c ier=-2 : normal return. the spline returned is the weighted least- +c squares constrained polynomial . in this extreme case +c fp gives the upper bound for the smoothing factor s. +c ier<-2 : warning. the coefficients of the spline returned have been +c computed as the minimal norm least-squares solution of a +c (numerically) rank deficient system. (-ier) gives the rank. +c especially if the rank deficiency which can be computed as +c 1+iopt(2)*(iopt(2)+3)/2+(nv-7)*(nu-5-iopt(2)-iopt(3))+ier +c is large the results may be inaccurate. +c they could also seriously depend on the value of eps. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameters nuest and +c nvest. +c probably causes : nuest or nvest too small. if these param- +c eters are already large, it may also indicate that s is +c too small +c the approximation returned is the weighted least-squares +c polar spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline with +c fp = s. probably causes : s too small or badly chosen eps. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=4 : error. no more knots can be added because the dimension +c of the spline 1+iopt(2)*(iopt(2)+3)/2+(nv-7)*(nu-5-iopt(2) +c -iopt(3)) already exceeds the number of data points m. +c probably causes : either s or m too small. +c the approximation returned is the weighted least-squares +c polar spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=5 : error. no more knots can be added because the additional +c knot would (quasi) coincide with an old one. +c probably causes : s too small or too large a weight to an +c inaccurate data point. +c the approximation returned is the weighted least-squares +c polar spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt(1)<=1 , 0<=iopt(2)<=2 , 0<=iopt(3)<=1 , +c m>=4-iopt(2)-iopt(3) , nuest>=8 ,nvest >=8, 00, i=1,...,m +c lwrk1 >= 129+10*k+21*l+k*l+(p+l*q)*(1+8*l+p)+8*m +c kwrk >= m+(nuest-7)*(nvest-7) +c if iopt(1)=-1:9<=nu<=nuest,9+iopt(2)*(iopt(2)+1)<=nv<=nvest +c 0=0: s>=0 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c ier>10 : error. lwrk2 is too small, i.e. there is not enough work- +c space for computing the minimal least-squares solution of +c a rank deficient system of linear equations. ier gives the +c requested value for lwrk2. there is no approximation re- +c turned but, having saved the information contained in nu, +c nv,tu,tv,wrk1,u,v and having adjusted the value of lwrk2 +c and the dimension of the array wrk2 accordingly, the user +c can continue at the point the program was left, by calling +c polar with iopt(1)=1. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the constrained weighted least-squares polynomial if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c z(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in z(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the least-squares +c polynomial and the corresponding upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximation shows more detail) to obtain closer fits. +c to choose s very small is strongly discouraged. this considerably +c increases computation time and memory requirements. it may also +c cause rank-deficiency (ier<-2) and endager numerical stability. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt(1)=0. +c if iopt(1)=1 the program will continue with the set of knots found +c at the last call of the routine. this will save a lot of computation +c time if polar is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. if the computation mode iopt(1)=1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt(1)=1,the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c polar once more with the selected value for s but now with iopt(1)=0 +c indeed, polar may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c the number of knots may also depend on the upper bounds nuest and +c nvest. indeed, if at a certain stage in polar the number of knots +c in one direction (say nu) has reached the value of its upper bound +c (nuest), then from that moment on all subsequent knots are added +c in the other (v) direction. this may indicate that the value of +c nuest is too small. on the other hand, it gives the user the option +c of limiting the number of knots the routine locates in any direction +c +c other subroutines required: +c fpback,fpbspl,fppola,fpdisc,fpgivs,fprank,fprati,fprota,fporde, +c fprppo +c +c references: +c dierckx p.: an algorithm for fitting data over a circle using tensor +c product splines,j.comp.appl.maths 15 (1986) 161-173. +c dierckx p.: an algorithm for fitting data on a circle using tensor +c product splines, report tw68, dept. computer science, +c k.u.leuven, 1984. +c dierckx p.: curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : june 1984 +c latest update : march 1989 +c +c .. +c ..scalar arguments.. + real*8 s,eps,fp + integer m,nuest,nvest,nu,nv,lwrk1,lwrk2,kwrk,ier +c ..array arguments.. + real*8 x(m),y(m),z(m),w(m),tu(nuest),tv(nvest),u(m),v(m), + * c((nuest-4)*(nvest-4)),wrk1(lwrk1),wrk2(lwrk2) + integer iopt(3),iwrk(kwrk) +c ..user specified function + real*8 rad +c ..local scalars.. + real*8 tol,pi,dist,r,one + integer i,ib1,ib3,ki,kn,kwest,la,lbu,lcc,lcs,lro,j, + * lbv,lco,lf,lff,lfp,lh,lq,lsu,lsv,lwest,maxit,ncest,ncc,nuu, + * nvv,nreg,nrint,nu4,nv4,iopt1,iopt2,iopt3,ipar,nvmin +c ..function references.. + real*8 datan2,sqrt + external rad +c ..subroutine references.. +c fppola +c .. +c set up constants + one = 1d0 +c we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid,control is immediately repassed to the calling program. + ier = 10 + if(eps.le.0. .or. eps.ge.1.) go to 60 + iopt1 = iopt(1) + if(iopt1.lt.(-1) .or. iopt1.gt.1) go to 60 + iopt2 = iopt(2) + if(iopt2.lt.0 .or. iopt2.gt.2) go to 60 + iopt3 = iopt(3) + if(iopt3.lt.0 .or. iopt3.gt.1) go to 60 + if(m.lt.(4-iopt2-iopt3)) go to 60 + if(nuest.lt.8 .or. nvest.lt.8) go to 60 + nu4 = nuest-4 + nv4 = nvest-4 + ncest = nu4*nv4 + nuu = nuest-7 + nvv = nvest-7 + ipar = 1+iopt2*(iopt2+3)/2 + ncc = ipar+nvv*(nuest-5-iopt2-iopt3) + nrint = nuu+nvv + nreg = nuu*nvv + ib1 = 4*nvv + ib3 = ib1+ipar + lwest = ncc*(1+ib1+ib3)+2*nrint+ncest+m*8+ib3+5*nuest+12*nvest + kwest = m+nreg + if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 60 + if(iopt1.gt.0) go to 40 + do 10 i=1,m + if(w(i).le.0.) go to 60 + dist = x(i)**2+y(i)**2 + u(i) = 0. + v(i) = 0. + if(dist.le.0.) go to 10 + v(i) = datan2(y(i),x(i)) + r = rad(v(i)) + if(r.le.0.) go to 60 + u(i) = sqrt(dist)/r + if(u(i).gt.one) go to 60 + 10 continue + if(iopt1.eq.0) go to 40 + nuu = nu-8 + if(nuu.lt.1 .or. nu.gt.nuest) go to 60 + tu(4) = 0. + do 20 i=1,nuu + j = i+4 + if(tu(j).le.tu(j-1) .or. tu(j).ge.one) go to 60 + 20 continue + nvv = nv-8 + nvmin = 9+iopt2*(iopt2+1) + if(nv.lt.nvmin .or. nv.gt.nvest) go to 60 + pi = datan2(0d0,-one) + tv(4) = -pi + do 30 i=1,nvv + j = i+4 + if(tv(j).le.tv(j-1) .or. tv(j).ge.pi) go to 60 + 30 continue + go to 50 + 40 if(s.lt.0.) go to 60 + 50 ier = 0 +c we partition the working space and determine the spline approximation + kn = 1 + ki = kn+m + lq = 2 + la = lq+ncc*ib3 + lf = la+ncc*ib1 + lff = lf+ncc + lfp = lff+ncest + lco = lfp+nrint + lh = lco+nrint + lbu = lh+ib3 + lbv = lbu+5*nuest + lro = lbv+5*nvest + lcc = lro+nvest + lcs = lcc+nvest + lsu = lcs+nvest*5 + lsv = lsu+m*4 + call fppola(iopt1,iopt2,iopt3,m,u,v,z,w,rad,s,nuest,nvest,eps,tol, + * + * maxit,ib1,ib3,ncest,ncc,nrint,nreg,nu,tu,nv,tv,c,fp,wrk1(1), + * wrk1(lfp),wrk1(lco),wrk1(lf),wrk1(lff),wrk1(lro),wrk1(lcc), + * wrk1(lcs),wrk1(la),wrk1(lq),wrk1(lbu),wrk1(lbv),wrk1(lsu), + * wrk1(lsv),wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier) + 60 return + end + diff --git a/fitpack/profil.f b/fitpack/profil.f new file mode 100644 index 0000000..ee01236 --- /dev/null +++ b/fitpack/profil.f @@ -0,0 +1,118 @@ + recursive subroutine profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier) + implicit none +c if iopt=0 subroutine profil calculates the b-spline coefficients of +c the univariate spline f(y) = s(u,y) with s(x,y) a bivariate spline of +c degrees kx and ky, given in the b-spline representation. +c if iopt = 1 it calculates the b-spline coefficients of the univariate +c spline g(x) = s(x,u) +c +c calling sequence: +c call profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier) +c +c input parameters: +c iopt : integer flag, specifying whether the profile f(y) (iopt=0) +c or the profile g(x) (iopt=1) must be determined. +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c u : real value, specifying the requested profile. +c tx(kx+1)<=u<=tx(nx-kx), if iopt=0. +c ty(ky+1)<=u<=ty(ny-ky), if iopt=1. +c nu : on entry nu must specify the dimension of the array cu. +c nu >= ny if iopt=0, nu >= nx if iopt=1. +c +c output parameters: +c cu : real array of dimension (nu). +c on successful exit this array contains the b-spline +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c if iopt=0 : tx(kx+1) <= u <= tx(nx-kx), nu >=ny. +c if iopt=1 : ty(ky+1) <= u <= ty(ny-ky), nu >=nx. +c +c other subroutines required: +c fpbspl +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer iopt,nx,ny,kx,ky,nu,ier + real*8 u +c ..array arguments.. + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),cu(nu) +c ..local scalars.. + integer i,j,kx1,ky1,l,l1,m,m0,nkx1,nky1 + real*8 sum +c ..local array + real*8 h(6) +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + kx1 = kx+1 + ky1 = ky+1 + nkx1 = nx-kx1 + nky1 = ny-ky1 + ier = 10 + if(iopt.ne.0) go to 200 + if(nu.lt.ny) go to 300 + if(u.lt.tx(kx1) .or. u.gt.tx(nkx1+1)) go to 300 +c the b-splinecoefficients of f(y) = s(u,y). + ier = 0 + l = kx1 + l1 = l+1 + 110 if(u.lt.tx(l1) .or. l.eq.nkx1) go to 120 + l = l1 + l1 = l+1 + go to 110 + 120 call fpbspl(tx,nx,kx,u,l,h) + m0 = (l-kx1)*nky1+1 + do 140 i=1,nky1 + m = m0 + sum = 0. + do 130 j=1,kx1 + sum = sum+h(j)*c(m) + m = m+nky1 + 130 continue + cu(i) = sum + m0 = m0+1 + 140 continue + go to 300 + 200 if(nu.lt.nx) go to 300 + if(u.lt.ty(ky1) .or. u.gt.ty(nky1+1)) go to 300 +c the b-splinecoefficients of g(x) = s(x,u). + ier = 0 + l = ky1 + l1 = l+1 + 210 if(u.lt.ty(l1) .or. l.eq.nky1) go to 220 + l = l1 + l1 = l+1 + go to 210 + 220 call fpbspl(ty,ny,ky,u,l,h) + m0 = l-ky + do 240 i=1,nkx1 + m = m0 + sum = 0. + do 230 j=1,ky1 + sum = sum+h(j)*c(m) + m = m+1 + 230 continue + cu(i) = sum + m0 = m0+nky1 + 240 continue + 300 return + end + diff --git a/fitpack/regrid.f b/fitpack/regrid.f new file mode 100644 index 0000000..0410020 --- /dev/null +++ b/fitpack/regrid.f @@ -0,0 +1,354 @@ + recursive subroutine regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s, + * nxest,nyest,nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier) + implicit none +c given the set of values z(i,j) on the rectangular grid (x(i),y(j)), +c i=1,...,mx;j=1,...,my, subroutine regrid determines a smooth bivar- +c iate spline approximation s(x,y) of degrees kx and ky on the rect- +c angle xb <= x <= xe, yb <= y <= ye. +c if iopt = -1 regrid calculates the least-squares spline according +c to a given set of knots. +c if iopt >= 0 the total numbers nx and ny of these knots and their +c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic- +c ally by the routine. the smoothness of s(x,y) is then achieved by +c minimalizing the discontinuity jumps in the derivatives of s(x,y) +c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1). +c the amounth of smoothness is determined by the condition that f(p) = +c sum ((z(i,j)-s(x(i),y(j))))**2) be <= s, with s a given non-negative +c constant, called the smoothing factor. +c the fit is given in the b-spline representation (b-spline coefficients +c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval- +c uated by means of subroutine bispev. +c +c calling sequence: +c call regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,nxest,nyest, +c * nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a least- +c squares spline (iopt=-1) or a smoothing spline (iopt=0 or 1) +c must be determined. +c if iopt=0 the routine will start with an initial set of knots +c tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i= +c 1,...,ky+1. if iopt=1 the routine will continue with the set +c of knots found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately pre- +c ceded by another call with iopt=1 or iopt=0 and +c s.ne.0. +c unchanged on exit. +c mx : integer. on entry mx must specify the number of grid points +c along the x-axis. mx > kx . unchanged on exit. +c x : real array of dimension at least (mx). before entry, x(i) +c must be set to the x-co-ordinate of the i-th grid point +c along the x-axis, for i=1,2,...,mx. these values must be +c supplied in strictly ascending order. unchanged on exit. +c my : integer. on entry my must specify the number of grid points +c along the y-axis. my > ky . unchanged on exit. +c y : real array of dimension at least (my). before entry, y(j) +c must be set to the y-co-ordinate of the j-th grid point +c along the y-axis, for j=1,2,...,my. these values must be +c supplied in strictly ascending order. unchanged on exit. +c z : real array of dimension at least (mx*my). +c before entry, z(my*(i-1)+j) must be set to the data value at +c the grid point (x(i),y(j)) for i=1,...,mx and j=1,...,my. +c unchanged on exit. +c xb,xe : real values. on entry xb,xe,yb and ye must specify the bound- +c yb,ye aries of the rectangular approximation domain. +c xb<=x(i)<=xe,i=1,...,mx; yb<=y(j)<=ye,j=1,...,my. +c unchanged on exit. +c kx,ky : integer values. on entry kx and ky must specify the degrees +c of the spline. 1<=kx,ky<=5. it is recommended to use bicubic +c (kx=ky=3) splines. unchanged on exit. +c s : real. on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments +c nxest : integer. unchanged on exit. +c nyest : integer. unchanged on exit. +c on entry, nxest and nyest must specify an upper bound for the +c number of knots required in the x- and y-directions respect. +c these numbers will also determine the storage space needed by +c the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1). +c in most practical situation nxest = mx/2, nyest=my/2, will +c be sufficient. always large enough are nxest=mx+kx+1, nyest= +c my+ky+1, the number of knots needed for interpolation (s=0). +c see also further comments. +c nx : integer. +c unless ier=10 (in case iopt >=0), nx will contain the total +c number of knots with respect to the x-variable, of the spline +c approximation returned. if the computation mode iopt=1 is +c used, the value of nx should be left unchanged between sub- +c sequent calls. +c in case iopt=-1, the value of nx should be specified on entry +c tx : real array of dimension nmax. +c on successful exit, this array will contain the knots of the +c spline with respect to the x-variable, i.e. the position of +c the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the +c position of the additional knots tx(1)=...=tx(kx+1)=xb and +c tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat. +c if the computation mode iopt=1 is used, the values of tx(1), +c ...,tx(nx) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values tx(kx+2), +c ...tx(nx-kx-1) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c ny : integer. +c unless ier=10 (in case iopt >=0), ny will contain the total +c number of knots with respect to the y-variable, of the spline +c approximation returned. if the computation mode iopt=1 is +c used, the value of ny should be left unchanged between sub- +c sequent calls. +c in case iopt=-1, the value of ny should be specified on entry +c ty : real array of dimension nmax. +c on successful exit, this array will contain the knots of the +c spline with respect to the y-variable, i.e. the position of +c the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the +c position of the additional knots ty(1)=...=ty(ky+1)=yb and +c ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat. +c if the computation mode iopt=1 is used, the values of ty(1), +c ...,ty(ny) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values ty(ky+2), +c ...ty(ny-ky-1) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1). +c on successful exit, c contains the coefficients of the spline +c approximation s(x,y) +c fp : real. unless ier=10, fp contains the sum of squared +c residuals of the spline approximation returned. +c wrk : real array of dimension (lwrk). used as workspace. +c if the computation mode iopt=1 is used the values of wrk(1), +c ...,wrk(4) should be left unchanged between subsequent calls. +c lwrk : integer. on entry lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program. +c lwrk must not be too small. +c lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+ +c my*(ky+1) +u +c where u is the larger of my and nxest. +c iwrk : integer array of dimension (kwrk). used as workspace. +c if the computation mode iopt=1 is used the values of iwrk(1), +c ...,iwrk(3) should be left unchanged between subsequent calls +c kwrk : integer. on entry kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. +c kwrk >= 3+mx+my+nxest+nyest. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c spline (fp=0). +c ier=-2 : normal return. the spline returned is the least-squares +c polynomial of degrees kx and ky. in this extreme case fp +c gives the upper bound for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameters nxest and +c nyest. +c probably causes : nxest or nyest too small. if these param- +c eters are already large, it may also indicate that s is +c too small +c the approximation returned is the least-squares spline +c according to the current set of knots. the parameter fp +c gives the corresponding sum of squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline with +c fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 1<=kx,ky<=5, mx>kx, my>ky, nxest>=2*kx+2, +c nyest>=2*ky+2, kwrk>=3+mx+my+nxest+nyest, +c lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+ +c my*(ky+1) +max(my,nxest), +c xb<=x(i-1)=0: s>=0 +c if s=0 : nxest>=mx+kx+1, nyest>=my+ky+1 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c regrid does not allow individual weighting of the data-values. +c so, if these were determined to widely different accuracies, then +c perhaps the general data set routine surfit should rather be used +c in spite of efficiency. +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the least-squares polynomial (degrees kx,ky) if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the accuracy of the data values. +c if the user has an idea of the statistical errors on the data, he +c can also find a proper estimate for s. for, by assuming that, if he +c specifies the right s, regrid will return a spline s(x,y) which +c exactly reproduces the function underlying the data he can evaluate +c the sum((z(i,j)-s(x(i),y(j)))**2) to find a good estimate for this s +c for example, if he knows that the statistical errors on his z(i,j)- +c values is not greater than 0.1, he may expect that a good s should +c have a value not larger than mx*my*(0.1)**2. +c if nothing is known about the statistical error in z(i,j), s must +c be determined by trial and error, taking account of the comments +c above. the best is then to start with a very large value of s (to +c determine the least-squares polynomial and the corresponding upper +c bound fp0 for s) and then to progressively decrease the value of s +c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... +c and more carefully as the approximation shows more detail) to +c obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if regrid is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. if the computation mode iopt=1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c regrid once more with the selected value for s but now with iopt=0. +c indeed, regrid may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c the number of knots may also depend on the upper bounds nxest and +c nyest. indeed, if at a certain stage in regrid the number of knots +c in one direction (say nx) has reached the value of its upper bound +c (nxest), then from that moment on all subsequent knots are added +c in the other (y) direction. this may indicate that the value of +c nxest is too small. on the other hand, it gives the user the option +c of limiting the number of knots the routine locates in any direction +c for example, by setting nxest=2*kx+2 (the lowest allowable value for +c nxest), the user can indicate that he wants an approximation which +c is a simple polynomial of degree kx in the variable x. +c +c other subroutines required: +c fpback,fpbspl,fpregr,fpdisc,fpgivs,fpgrre,fprati,fprota,fpchec, +c fpknot +c +c references: +c dierckx p. : a fast algorithm for smoothing data on a rectangular +c grid while using spline functions, siam j.numer.anal. +c 19 (1982) 1286-1304. +c dierckx p. : a fast algorithm for smoothing data on a rectangular +c grid while using spline functions, report tw53, dept. +c computer science,k.u.leuven, 1980. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1989 +c +c .. +c ..scalar arguments.. + real*8 xb,xe,yb,ye,s,fp + integer iopt,mx,my,kx,ky,nxest,nyest,nx,ny,lwrk,kwrk,ier +c ..array arguments.. + real*8 x(mx),y(my),z(mx*my),tx(nxest),ty(nyest), + * c((nxest-kx-1)*(nyest-ky-1)),wrk(lwrk) + integer iwrk(kwrk) +c ..local scalars.. + real*8 tol + integer i,j,jwrk,kndx,kndy,knrx,knry,kwest,kx1,kx2,ky1,ky2, + * lfpx,lfpy,lwest,lww,maxit,nc,nminx,nminy,mz +c ..function references.. + integer max0 +c ..subroutine references.. +c fpregr,fpchec +c .. +c we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(kx.le.0 .or. kx.gt.5) go to 70 + kx1 = kx+1 + kx2 = kx1+1 + if(ky.le.0 .or. ky.gt.5) go to 70 + ky1 = ky+1 + ky2 = ky1+1 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 70 + nminx = 2*kx1 + if(mx.lt.kx1 .or. nxest.lt.nminx) go to 70 + nminy = 2*ky1 + if(my.lt.ky1 .or. nyest.lt.nminy) go to 70 + mz = mx*my + nc = (nxest-kx1)*(nyest-ky1) + lwest = 4+nxest*(my+2*kx2+1)+nyest*(2*ky2+1)+mx*kx1+ + * my*ky1+max0(nxest,my) + kwest = 3+mx+my+nxest+nyest + if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 70 + if(xb.gt.x(1) .or. xe.lt.x(mx)) go to 70 + do 10 i=2,mx + if(x(i-1).ge.x(i)) go to 70 + 10 continue + if(yb.gt.y(1) .or. ye.lt.y(my)) go to 70 + do 20 i=2,my + if(y(i-1).ge.y(i)) go to 70 + 20 continue + if(iopt.ge.0) go to 50 + if(nx.lt.nminx .or. nx.gt.nxest) go to 70 + j = nx + do 30 i=1,kx1 + tx(i) = xb + tx(j) = xe + j = j-1 + 30 continue + call fpchec(x,mx,tx,nx,kx,ier) + if(ier.ne.0) go to 70 + if(ny.lt.nminy .or. ny.gt.nyest) go to 70 + j = ny + do 40 i=1,ky1 + ty(i) = yb + ty(j) = ye + j = j-1 + 40 continue + call fpchec(y,my,ty,ny,ky,ier) + if (ier.eq.0) go to 60 + go to 70 + 50 if(s.lt.0.) go to 70 + if(s.eq.0. .and. (nxest.lt.(mx+kx1) .or. nyest.lt.(my+ky1)) ) + * go to 70 + ier = 0 +c we partition the working space and determine the spline approximation + 60 lfpx = 5 + lfpy = lfpx+nxest + lww = lfpy+nyest + jwrk = lwrk-4-nxest-nyest + knrx = 4 + knry = knrx+mx + kndx = knry+my + kndy = kndx+nxest + call fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s,nxest,nyest, + * tol,maxit,nc,nx,tx,ny,ty,c,fp,wrk(1),wrk(2),wrk(3),wrk(4), + * wrk(lfpx),wrk(lfpy),iwrk(1),iwrk(2),iwrk(3),iwrk(knrx), + * iwrk(knry),iwrk(kndx),iwrk(kndy),wrk(lww),jwrk,ier) + 70 return + end + diff --git a/fitpack/spalde.f b/fitpack/spalde.f new file mode 100644 index 0000000..66212d4 --- /dev/null +++ b/fitpack/spalde.f @@ -0,0 +1,75 @@ + recursive subroutine spalde(t,n,c,nc,k1,x,d,ier) + implicit none +c subroutine spalde evaluates at a point x all the derivatives +c (j-1) +c d(j) = s (x) , j=1,2,...,k1 +c of a spline s(x) of order k1 (degree k=k1-1), given in its b-spline +c representation. +c +c calling sequence: +c call spalde(t,n,c,k1,x,d,ier) +c +c input parameters: +c t : array,length n, which contains the position of the knots. +c n : integer, giving the total number of knots of s(x). +c c : array,length nc, which contains the b-spline coefficients. +c nc : integer, giving the total number of coefficients (must be >= n-k1) +c k1 : integer, giving the order of s(x) (order=degree+1) +c x : real, which contains the point where the derivatives must +c be evaluated. +c +c output parameters: +c d : array,length k1, containing the derivative values of s(x). +c ier : error flag +c ier = 0 : normal return +c ier =10 : invalid input data (see restrictions) +c +c restrictions: +c t(k1) <= x <= t(n-k1+1) +c +c further comments: +c if x coincides with a knot, right derivatives are computed +c ( left derivatives if x = t(n-k1+1) ). +c +c other subroutines required: fpader. +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer n,nc,k1,ier + real*8 x +c ..array arguments.. + real*8 t(n),c(nc),d(k1) +c ..local scalars.. + integer l,nk1 +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + nk1 = n-k1 + if(x.lt.t(k1) .or. x.gt.t(nk1+1)) go to 300 +c search for knot interval t(l) <= x < t(l+1) + l = k1 + 100 if(x.lt.t(l+1) .or. l.eq.nk1) go to 200 + l = l+1 + go to 100 + 200 if(t(l).ge.t(l+1)) go to 300 + ier = 0 +c calculate the derivatives. + call fpader(t,n,c,k1,x,l,d) + 300 return + end diff --git a/fitpack/spgrid.f b/fitpack/spgrid.f new file mode 100644 index 0000000..60e8fa5 --- /dev/null +++ b/fitpack/spgrid.f @@ -0,0 +1,502 @@ + recursive subroutine spgrid(iopt,ider,mu,u,mv,v,r,r0,r1,s, + * nuest,nvest,nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) + implicit none +c given the function values r(i,j) on the latitude-longitude grid +c (u(i),v(j)), i=1,...,mu ; j=1,...,mv , spgrid determines a smooth +c bicubic spline approximation on the rectangular domain 0<=u<=pi, +c vb<=v<=ve (vb = v(1), ve=vb+2*pi). +c this approximation s(u,v) will satisfy the properties +c +c (1) s(0,v) = s(0,0) = dr(1) +c +c d s(0,v) d s(0,0) d s(0,pi/2) +c (2) -------- = cos(v)* -------- + sin(v)* ----------- +c d u d u d u +c +c = cos(v)*dr(2)+sin(v)*dr(3) +c vb <= v <= ve +c (3) s(pi,v) = s(pi,0) = dr(4) +c +c d s(pi,v) d s(pi,0) d s(pi,pi/2) +c (4) -------- = cos(v)* --------- + sin(v)* ------------ +c d u d u d u +c +c = cos(v)*dr(5)+sin(v)*dr(6) +c +c and will be periodic in the variable v, i.e. +c +c j j +c d s(u,vb) d s(u,ve) +c (5) --------- = --------- 0 <=u<= pi , j=0,1,2 +c j j +c d v d v +c +c the number of knots of s(u,v) and their position tu(i),i=1,2,...,nu; +c tv(j),j=1,2,...,nv, is chosen automatically by the routine. the +c smoothness of s(u,v) is achieved by minimalizing the discontinuity +c jumps of the derivatives of the spline at the knots. the amount of +c smoothness of s(u,v) is determined by the condition that +c fp=sumi=1,mu(sumj=1,mv((r(i,j)-s(u(i),v(j)))**2))+(r0-s(0,v))**2 +c + (r1-s(pi,v))**2 <= s, with s a given non-negative constant. +c the fit s(u,v) is given in its b-spline representation and can be +c evaluated by means of routine bispev +c +c calling sequence: +c call spgrid(iopt,ider,mu,u,mv,v,r,r0,r1,s,nuest,nvest,nu,tu, +c * ,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) +c +c parameters: +c iopt : integer array of dimension 3, specifying different options. +c unchanged on exit. +c iopt(1):on entry iopt(1) must specify whether a least-squares spline +c (iopt(1)=-1) or a smoothing spline (iopt(1)=0 or 1) must be +c determined. +c if iopt(1)=0 the routine will start with an initial set of +c knots tu(i)=0,tu(i+4)=pi,i=1,...,4;tv(i)=v(1)+(i-4)*2*pi, +c i=1,...,8. +c if iopt(1)=1 the routine will continue with the set of knots +c found at the last call of the routine. +c attention: a call with iopt(1)=1 must always be immediately +c preceded by another call with iopt(1) = 1 or iopt(1) = 0. +c iopt(2):on entry iopt(2) must specify the requested order of conti- +c nuity at the pole u=0. +c if iopt(2)=0 only condition (1) must be fulfilled and +c if iopt(2)=1 conditions (1)+(2) must be fulfilled. +c iopt(3):on entry iopt(3) must specify the requested order of conti- +c nuity at the pole u=pi. +c if iopt(3)=0 only condition (3) must be fulfilled and +c if iopt(3)=1 conditions (3)+(4) must be fulfilled. +c ider : integer array of dimension 4, specifying different options. +c unchanged on exit. +c ider(1):on entry ider(1) must specify whether (ider(1)=0 or 1) or not +c (ider(1)=-1) there is a data value r0 at the pole u=0. +c if ider(1)=1, r0 will be considered to be the right function +c value, and it will be fitted exactly (s(0,v)=r0). +c if ider(1)=0, r0 will be considered to be a data value just +c like the other data values r(i,j). +c ider(2):on entry ider(2) must specify whether (ider(2)=1) or not +c (ider(2)=0) the approximation has vanishing derivatives +c dr(2) and dr(3) at the pole u=0 (in case iopt(2)=1) +c ider(3):on entry ider(3) must specify whether (ider(3)=0 or 1) or not +c (ider(3)=-1) there is a data value r1 at the pole u=pi. +c if ider(3)=1, r1 will be considered to be the right function +c value, and it will be fitted exactly (s(pi,v)=r1). +c if ider(3)=0, r1 will be considered to be a data value just +c like the other data values r(i,j). +c ider(4):on entry ider(4) must specify whether (ider(4)=1) or not +c (ider(4)=0) the approximation has vanishing derivatives +c dr(5) and dr(6) at the pole u=pi (in case iopt(3)=1) +c mu : integer. on entry mu must specify the number of grid points +c along the u-axis. unchanged on exit. +c mu >= 1, mu >=mumin=4-i0-i1-ider(2)-ider(4) with +c i0=min(1,ider(1)+1), i1=min(1,ider(3)+1) +c u : real array of dimension at least (mu). before entry, u(i) +c must be set to the u-co-ordinate of the i-th grid point +c along the u-axis, for i=1,2,...,mu. these values must be +c supplied in strictly ascending order. unchanged on exit. +c 0 < u(i) < pi. +c mv : integer. on entry mv must specify the number of grid points +c along the v-axis. mv > 3 . unchanged on exit. +c v : real array of dimension at least (mv). before entry, v(j) +c must be set to the v-co-ordinate of the j-th grid point +c along the v-axis, for j=1,2,...,mv. these values must be +c supplied in strictly ascending order. unchanged on exit. +c -pi <= v(1) < pi , v(mv) < v(1)+2*pi. +c r : real array of dimension at least (mu*mv). +c before entry, r(mv*(i-1)+j) must be set to the data value at +c the grid point (u(i),v(j)) for i=1,...,mu and j=1,...,mv. +c unchanged on exit. +c r0 : real value. on entry (if ider(1) >=0 ) r0 must specify the +c data value at the pole u=0. unchanged on exit. +c r1 : real value. on entry (if ider(1) >=0 ) r1 must specify the +c data value at the pole u=pi. unchanged on exit. +c s : real. on entry (if iopt(1)>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments +c nuest : integer. unchanged on exit. +c nvest : integer. unchanged on exit. +c on entry, nuest and nvest must specify an upper bound for the +c number of knots required in the u- and v-directions respect. +c these numbers will also determine the storage space needed by +c the routine. nuest >= 8, nvest >= 8. +c in most practical situation nuest = mu/2, nvest=mv/2, will +c be sufficient. always large enough are nuest=mu+6+iopt(2)+ +c iopt(3), nvest = mv+7, the number of knots needed for +c interpolation (s=0). see also further comments. +c nu : integer. +c unless ier=10 (in case iopt(1)>=0), nu will contain the total +c number of knots with respect to the u-variable, of the spline +c approximation returned. if the computation mode iopt(1)=1 is +c used, the value of nu should be left unchanged between sub- +c sequent calls. in case iopt(1)=-1, the value of nu should be +c specified on entry. +c tu : real array of dimension at least (nuest). +c on successful exit, this array will contain the knots of the +c spline with respect to the u-variable, i.e. the position of +c the interior knots tu(5),...,tu(nu-4) as well as the position +c of the additional knots tu(1)=...=tu(4)=0 and tu(nu-3)=...= +c tu(nu)=pi needed for the b-spline representation. +c if the computation mode iopt(1)=1 is used,the values of tu(1) +c ...,tu(nu) should be left unchanged between subsequent calls. +c if the computation mode iopt(1)=-1 is used, the values tu(5), +c ...tu(nu-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c nv : integer. +c unless ier=10 (in case iopt(1)>=0), nv will contain the total +c number of knots with respect to the v-variable, of the spline +c approximation returned. if the computation mode iopt(1)=1 is +c used, the value of nv should be left unchanged between sub- +c sequent calls. in case iopt(1) = -1, the value of nv should +c be specified on entry. +c tv : real array of dimension at least (nvest). +c on successful exit, this array will contain the knots of the +c spline with respect to the v-variable, i.e. the position of +c the interior knots tv(5),...,tv(nv-4) as well as the position +c of the additional knots tv(1),...,tv(4) and tv(nv-3),..., +c tv(nv) needed for the b-spline representation. +c if the computation mode iopt(1)=1 is used,the values of tv(1) +c ...,tv(nv) should be left unchanged between subsequent calls. +c if the computation mode iopt(1)=-1 is used, the values tv(5), +c ...tv(nv-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c c : real array of dimension at least (nuest-4)*(nvest-4). +c on successful exit, c contains the coefficients of the spline +c approximation s(u,v) +c fp : real. unless ier=10, fp contains the sum of squared +c residuals of the spline approximation returned. +c wrk : real array of dimension (lwrk). used as workspace. +c if the computation mode iopt(1)=1 is used the values of +c wrk(1),..,wrk(12) should be left unchanged between subsequent +c calls. +c lwrk : integer. on entry lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program. +c lwrk must not be too small. +c lwrk >= 12+nuest*(mv+nvest+3)+nvest*24+4*mu+8*mv+q +c where q is the larger of (mv+nvest) and nuest. +c iwrk : integer array of dimension (kwrk). used as workspace. +c if the computation mode iopt(1)=1 is used the values of +c iwrk(1),.,iwrk(5) should be left unchanged between subsequent +c calls. +c kwrk : integer. on entry kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. +c kwrk >= 5+mu+mv+nuest+nvest. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c spline (fp=0). +c ier=-2 : normal return. the spline returned is the least-squares +c constrained polynomial. in this extreme case fp gives the +c upper bound for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameters nuest and +c nvest. +c probably causes : nuest or nvest too small. if these param- +c eters are already large, it may also indicate that s is +c too small +c the approximation returned is the least-squares spline +c according to the current set of knots. the parameter fp +c gives the corresponding sum of squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline with +c fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt(1)<=1, 0<=iopt(2)<=1, 0<=iopt(3)<=1, +c -1<=ider(1)<=1, 0<=ider(2)<=1, ider(2)=0 if iopt(2)=0. +c -1<=ider(3)<=1, 0<=ider(4)<=1, ider(4)=0 if iopt(3)=0. +c mu >= mumin (see above), mv >= 4, nuest >=8, nvest >= 8, +c kwrk>=5+mu+mv+nuest+nvest, +c lwrk >= 12+nuest*(mv+nvest+3)+nvest*24+4*mu+8*mv+ +c max(nuest,mv+nvest) +c 0< u(i-1)=0: s>=0 +c if s=0: nuest>=mu+6+iopt(2)+iopt(3), nvest>=mv+7 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c spgrid does not allow individual weighting of the data-values. +c so, if these were determined to widely different accuracies, then +c perhaps the general data set routine sphere should rather be used +c in spite of efficiency. +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the constrained least-squares polynomial(degrees 3,0)if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the accuracy of the data values. +c if the user has an idea of the statistical errors on the data, he +c can also find a proper estimate for s. for, by assuming that, if he +c specifies the right s, spgrid will return a spline s(u,v) which +c exactly reproduces the function underlying the data he can evaluate +c the sum((r(i,j)-s(u(i),v(j)))**2) to find a good estimate for this s +c for example, if he knows that the statistical errors on his r(i,j)- +c values is not greater than 0.1, he may expect that a good s should +c have a value not larger than mu*mv*(0.1)**2. +c if nothing is known about the statistical error in r(i,j), s must +c be determined by trial and error, taking account of the comments +c above. the best is then to start with a very large value of s (to +c determine the least-squares polynomial and the corresponding upper +c bound fp0 for s) and then to progressively decrease the value of s +c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... +c and more carefully as the approximation shows more detail) to +c obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt(1)=0. +c if iopt(1) = 1 the program will continue with the knots found at +c the last call of the routine. this will save a lot of computation +c time if spgrid is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. if the computation mode iopt(1) = 1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt(1)=1,the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c spgrid once more with the chosen value for s but now with iopt(1)=0. +c indeed, spgrid may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c the number of knots may also depend on the upper bounds nuest and +c nvest. indeed, if at a certain stage in spgrid the number of knots +c in one direction (say nu) has reached the value of its upper bound +c (nuest), then from that moment on all subsequent knots are added +c in the other (v) direction. this may indicate that the value of +c nuest is too small. on the other hand, it gives the user the option +c of limiting the number of knots the routine locates in any direction +c for example, by setting nuest=8 (the lowest allowable value for +c nuest), the user can indicate that he wants an approximation which +c is a simple cubic polynomial in the variable u. +c +c other subroutines required: +c fpspgr,fpchec,fpchep,fpknot,fpopsp,fprati,fpgrsp,fpsysy,fpback, +c fpbacp,fpbspl,fpcyt1,fpcyt2,fpdisc,fpgivs,fprota +c +c references: +c dierckx p. : fast algorithms for smoothing data over a disc or a +c sphere using tensor product splines, in "algorithms +c for approximation", ed. j.c.mason and m.g.cox, +c clarendon press oxford, 1987, pp. 51-65 +c dierckx p. : fast algorithms for smoothing data over a disc or a +c sphere using tensor product splines, report tw73, dept. +c computer science,k.u.leuven, 1985. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : july 1985 +c latest update : march 1989 +c +c .. +c ..scalar arguments.. + real*8 r0,r1,s,fp + integer mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier +c ..array arguments.. + integer iopt(3),ider(4),iwrk(kwrk) + real*8 u(mu),v(mv),r(mu*mv),c((nuest-4)*(nvest-4)),tu(nuest), + * tv(nvest),wrk(lwrk) +c ..local scalars.. + real*8 per,pi,tol,uu,ve,rmax,rmin,one,half,rn,rb,re + integer i,i1,i2,j,jwrk,j1,j2,kndu,kndv,knru,knrv,kwest,l, + * ldr,lfpu,lfpv,lwest,lww,m,maxit,mumin,muu,nc +c ..function references.. + real*8 datan2 + integer max0 +c ..subroutine references.. +c fpchec,fpchep,fpspgr +c .. +c set constants + one = 1d0 + half = 0.5e0 + pi = datan2(0d0,-one) + per = pi+pi + ve = v(1)+per +c we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1e-02 +c before starting computations, a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(iopt(1).lt.(-1) .or. iopt(1).gt.1) go to 200 + if(iopt(2).lt.0 .or. iopt(2).gt.1) go to 200 + if(iopt(3).lt.0 .or. iopt(3).gt.1) go to 200 + if(ider(1).lt.(-1) .or. ider(1).gt.1) go to 200 + if(ider(2).lt.0 .or. ider(2).gt.1) go to 200 + if(ider(2).eq.1 .and. iopt(2).eq.0) go to 200 + if(ider(3).lt.(-1) .or. ider(3).gt.1) go to 200 + if(ider(4).lt.0 .or. ider(4).gt.1) go to 200 + if(ider(4).eq.1 .and. iopt(3).eq.0) go to 200 + mumin = 4 + if(ider(1).ge.0) mumin = mumin-1 + if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1 + if(ider(3).ge.0) mumin = mumin-1 + if(iopt(3).eq.1 .and. ider(4).eq.1) mumin = mumin-1 + if(mumin.eq.0) mumin = 1 + if(mu.lt.mumin .or. mv.lt.4) go to 200 + if(nuest.lt.8 .or. nvest.lt.8) go to 200 + m = mu*mv + nc = (nuest-4)*(nvest-4) + lwest = 12+nuest*(mv+nvest+3)+24*nvest+4*mu+8*mv+ + * max0(nuest,mv+nvest) + kwest = 5+mu+mv+nuest+nvest + if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200 + if(u(1).le.0. .or. u(mu).ge.pi) go to 200 + if(mu.eq.1) go to 30 + do 20 i=2,mu + if(u(i-1).ge.u(i)) go to 200 + 20 continue + 30 if(v(1).lt. (-pi) .or. v(1).ge.pi ) go to 200 + if(v(mv).ge.v(1)+per) go to 200 + do 40 i=2,mv + if(v(i-1).ge.v(i)) go to 200 + 40 continue + if(iopt(1).gt.0) go to 140 +c if not given, we compute an estimate for r0. + rn = mv + if(ider(1).lt.0) go to 45 + rb = r0 + go to 55 + 45 rb = 0. + do 50 i=1,mv + rb = rb+r(i) + 50 continue + rb = rb/rn +c if not given, we compute an estimate for r1. + 55 if(ider(3).lt.0) go to 60 + re = r1 + go to 70 + 60 re = 0. + j = m + do 65 i=1,mv + re = re+r(j) + j = j-1 + 65 continue + re = re/rn +c we determine the range of r-values. + 70 rmin = rb + rmax = re + do 80 i=1,m + if(r(i).lt.rmin) rmin = r(i) + if(r(i).gt.rmax) rmax = r(i) + 80 continue + wrk(5) = rb + wrk(6) = 0. + wrk(7) = 0. + wrk(8) = re + wrk(9) = 0. + wrk(10) = 0. + wrk(11) = rmax -rmin + wrk(12) = wrk(11) + iwrk(4) = mu + iwrk(5) = mu + if(iopt(1).eq.0) go to 140 + if(nu.lt.8 .or. nu.gt.nuest) go to 200 + if(nv.lt.11 .or. nv.gt.nvest) go to 200 + j = nu + do 90 i=1,4 + tu(i) = 0. + tu(j) = pi + j = j-1 + 90 continue + l = 13 + wrk(l) = 0. + if(iopt(2).eq.0) go to 100 + l = l+1 + uu = u(1) + if(uu.gt.tu(5)) uu = tu(5) + wrk(l) = uu*half + 100 do 110 i=1,mu + l = l+1 + wrk(l) = u(i) + 110 continue + if(iopt(3).eq.0) go to 120 + l = l+1 + uu = u(mu) + if(uu.lt.tu(nu-4)) uu = tu(nu-4) + wrk(l) = uu+(pi-uu)*half + 120 l = l+1 + wrk(l) = pi + muu = l-12 + call fpchec(wrk(13),muu,tu,nu,3,ier) + if(ier.ne.0) go to 200 + j1 = 4 + tv(j1) = v(1) + i1 = nv-3 + tv(i1) = ve + j2 = j1 + i2 = i1 + do 130 i=1,3 + i1 = i1+1 + i2 = i2-1 + j1 = j1+1 + j2 = j2-1 + tv(j2) = tv(i2)-per + tv(i1) = tv(j1)+per + 130 continue + l = 13 + do 135 i=1,mv + wrk(l) = v(i) + l = l+1 + 135 continue + wrk(l) = ve + call fpchep(wrk(13),mv+1,tv,nv,3,ier) + if (ier.eq.0) go to 150 + go to 200 + 140 if(s.lt.0.) go to 200 + if(s.eq.0. .and. (nuest.lt.(mu+6+iopt(2)+iopt(3)) .or. + * nvest.lt.(mv+7)) ) go to 200 +c we partition the working space and determine the spline approximation + 150 ldr = 5 + lfpu = 13 + lfpv = lfpu+nuest + lww = lfpv+nvest + jwrk = lwrk-12-nuest-nvest + knru = 6 + knrv = knru+mu + kndu = knrv+mv + kndv = kndu+nuest + call fpspgr(iopt,ider,u,mu,v,mv,r,m,rb,re,s,nuest,nvest,tol,maxit, + * + * nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),wrk(lfpu), + * wrk(lfpv),wrk(ldr),wrk(11),iwrk(1),iwrk(2),iwrk(3),iwrk(4), + * iwrk(5),iwrk(knru),iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww), + * jwrk,ier) + 200 return + end diff --git a/fitpack/sphere.f b/fitpack/sphere.f new file mode 100644 index 0000000..97b0a82 --- /dev/null +++ b/fitpack/sphere.f @@ -0,0 +1,405 @@ + recursive subroutine sphere(iopt,m,teta,phi,r,w,s,ntest,npest, + * eps,nt,tt,np,tp,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) + implicit none +c subroutine sphere determines a smooth bicubic spherical spline +c approximation s(teta,phi), 0 <= teta <= pi ; 0 <= phi <= 2*pi +c to a given set of data points (teta(i),phi(i),r(i)),i=1,2,...,m. +c such a spline has the following specific properties +c +c (1) s(0,phi) = constant 0 <=phi<= 2*pi. +c +c (2) s(pi,phi) = constant 0 <=phi<= 2*pi +c +c j j +c d s(teta,0) d s(teta,2*pi) +c (3) ----------- = ------------ 0 <=teta<=pi, j=0,1,2 +c j j +c d phi d phi +c +c d s(0,phi) d s(0,0) d s(0,pi/2) +c (4) ---------- = -------- *cos(phi) + ----------- *sin(phi) +c d teta d teta d teta +c +c d s(pi,phi) d s(pi,0) d s(pi,pi/2) +c (5) ----------- = ---------*cos(phi) + ------------*sin(phi) +c d teta d teta d teta +c +c if iopt =-1 sphere calculates a weighted least-squares spherical +c spline according to a given set of knots in teta- and phi- direction. +c if iopt >=0, the number of knots in each direction and their position +c tt(j),j=1,2,...,nt ; tp(j),j=1,2,...,np are chosen automatically by +c the routine. the smoothness of s(teta,phi) is then achieved by mini- +c malizing the discontinuity jumps of the derivatives of the spline +c at the knots. the amount of smoothness of s(teta,phi) is determined +c by the condition that fp = sum((w(i)*(r(i)-s(teta(i),phi(i))))**2) +c be <= s, with s a given non-negative constant. +c the spherical spline is given in the standard b-spline representation +c of bicubic splines and can be evaluated by means of subroutine bispev +c +c calling sequence: +c call sphere(iopt,m,teta,phi,r,w,s,ntest,npest,eps, +c * nt,tt,np,tp,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a weighted +c least-squares spherical spline (iopt=-1) or a smoothing +c spherical spline (iopt=0 or 1) must be determined. +c if iopt=0 the routine will start with an initial set of knots +c tt(i)=0,tt(i+4)=pi,i=1,...,4;tp(i)=0,tp(i+4)=2*pi,i=1,...,4. +c if iopt=1 the routine will continue with the set of knots +c found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately pre- +c ceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m >= 2. unchanged on exit. +c teta : real array of dimension at least (m). +c phi : real array of dimension at least (m). +c r : real array of dimension at least (m). +c before entry,teta(i),phi(i),r(i) must be set to the spherical +c co-ordinates of the i-th data point, for i=1,...,m.the order +c of the data points is immaterial. unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) must +c be set to the i-th value in the set of weights. the w(i) must +c be strictly positive. unchanged on exit. +c s : real. on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments +c ntest : integer. unchanged on exit. +c npest : integer. unchanged on exit. +c on entry, ntest and npest must specify an upper bound for the +c number of knots required in the teta- and phi-directions. +c these numbers will also determine the storage space needed by +c the routine. ntest >= 8, npest >= 8. +c in most practical situation ntest = npest = 8+sqrt(m/2) will +c be sufficient. see also further comments. +c eps : real. +c on entry, eps must specify a threshold for determining the +c effective rank of an over-determined linear system of equat- +c ions. 0 < eps < 1. if the number of decimal digits in the +c computer representation of a real number is q, then 10**(-q) +c is a suitable value for eps in most practical applications. +c unchanged on exit. +c nt : integer. +c unless ier=10 (in case iopt >=0), nt will contain the total +c number of knots with respect to the teta-variable, of the +c spline approximation returned. if the computation mode iopt=1 +c is used, the value of nt should be left unchanged between +c subsequent calls. +c in case iopt=-1, the value of nt should be specified on entry +c tt : real array of dimension at least ntest. +c on successful exit, this array will contain the knots of the +c spline with respect to the teta-variable, i.e. the position +c of the interior knots tt(5),...,tt(nt-4) as well as the +c position of the additional knots tt(1)=...=tt(4)=0 and +c tt(nt-3)=...=tt(nt)=pi needed for the b-spline representation +c if the computation mode iopt=1 is used, the values of tt(1), +c ...,tt(nt) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values tt(5), +c ...tt(nt-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c np : integer. +c unless ier=10 (in case iopt >=0), np will contain the total +c number of knots with respect to the phi-variable, of the +c spline approximation returned. if the computation mode iopt=1 +c is used, the value of np should be left unchanged between +c subsequent calls. +c in case iopt=-1, the value of np (>=9) should be specified +c on entry. +c tp : real array of dimension at least npest. +c on successful exit, this array will contain the knots of the +c spline with respect to the phi-variable, i.e. the position of +c the interior knots tp(5),...,tp(np-4) as well as the position +c of the additional knots tp(1),...,tp(4) and tp(np-3),..., +c tp(np) needed for the b-spline representation. +c if the computation mode iopt=1 is used, the values of tp(1), +c ...,tp(np) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values tp(5), +c ...tp(np-4) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c c : real array of dimension at least (ntest-4)*(npest-4). +c on successful exit, c contains the coefficients of the spline +c approximation s(teta,phi). +c fp : real. unless ier=10, fp contains the weighted sum of +c squared residuals of the spline approximation returned. +c wrk1 : real array of dimension (lwrk1). used as workspace. +c if the computation mode iopt=1 is used the value of wrk1(1) +c should be left unchanged between subsequent calls. +c on exit wrk1(2),wrk1(3),...,wrk1(1+ncof) will contain the +c values d(i)/max(d(i)),i=1,...,ncof=6+(np-7)*(nt-8) +c with d(i) the i-th diagonal element of the reduced triangular +c matrix for calculating the b-spline coefficients. it includes +c those elements whose square is less than eps,which are treat- +c ed as 0 in the case of presumed rank deficiency (ier<-2). +c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of +c the array wrk1 as declared in the calling (sub)program. +c lwrk1 must not be too small. let +c u = ntest-7, v = npest-7, then +c lwrk1 >= 185+52*v+10*u+14*u*v+8*(u-1)*v**2+8*m +c wrk2 : real array of dimension (lwrk2). used as workspace, but +c only in the case a rank deficient system is encountered. +c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of +c the array wrk2 as declared in the calling (sub)program. +c lwrk2 > 0 . a save upper bound for lwrk2 = 48+21*v+7*u*v+ +c 4*(u-1)*v**2 where u,v are as above. if there are enough data +c points, scattered uniformly over the approximation domain +c and if the smoothing factor s is not too small, there is a +c good chance that this extra workspace is not needed. a lot +c of memory might therefore be saved by setting lwrk2=1. +c (see also ier > 10) +c iwrk : integer array of dimension (kwrk). used as workspace. +c kwrk : integer. on entry kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. +c kwrk >= m+(ntest-7)*(npest-7). +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is a spherical +c interpolating spline (fp=0). +c ier=-2 : normal return. the spline returned is the weighted least- +c squares constrained polynomial . in this extreme case +c fp gives the upper bound for the smoothing factor s. +c ier<-2 : warning. the coefficients of the spline returned have been +c computed as the minimal norm least-squares solution of a +c (numerically) rank deficient system. (-ier) gives the rank. +c especially if the rank deficiency which can be computed as +c 6+(nt-8)*(np-7)+ier, is large the results may be inaccurate +c they could also seriously depend on the value of eps. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameters ntest and +c npest. +c probably causes : ntest or npest too small. if these param- +c eters are already large, it may also indicate that s is +c too small +c the approximation returned is the weighted least-squares +c spherical spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline with +c fp = s. probably causes : s too small or badly chosen eps. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=4 : error. no more knots can be added because the dimension +c of the spherical spline 6+(nt-8)*(np-7) already exceeds +c the number of data points m. +c probably causes : either s or m too small. +c the approximation returned is the weighted least-squares +c spherical spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=5 : error. no more knots can be added because the additional +c knot would (quasi) coincide with an old one. +c probably causes : s too small or too large a weight to an +c inaccurate data point. +c the approximation returned is the weighted least-squares +c spherical spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, m>=2, ntest>=8 ,npest >=8, 00, i=1,...,m +c lwrk1 >= 185+52*v+10*u+14*u*v+8*(u-1)*v**2+8*m +c kwrk >= m+(ntest-7)*(npest-7) +c if iopt=-1: 8<=nt<=ntest , 9<=np<=npest +c 0=0: s>=0 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c ier>10 : error. lwrk2 is too small, i.e. there is not enough work- +c space for computing the minimal least-squares solution of +c a rank deficient system of linear equations. ier gives the +c requested value for lwrk2. there is no approximation re- +c turned but, having saved the information contained in nt, +c np,tt,tp,wrk1, and having adjusted the value of lwrk2 and +c the dimension of the array wrk2 accordingly, the user can +c continue at the point the program was left, by calling +c sphere with iopt=1. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the constrained weighted least-squares polynomial if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c r(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in r(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the least-squares +c polynomial and the corresponding upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximation shows more detail) to obtain closer fits. +c to choose s very small is strongly discouraged. this considerably +c increases computation time and memory requirements. it may also +c cause rank-deficiency (ier<-2) and endager numerical stability. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if sphere is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. if the computation mode iopt=1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c sphere once more with the selected value for s but now with iopt=0. +c indeed, sphere may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c the number of knots may also depend on the upper bounds ntest and +c npest. indeed, if at a certain stage in sphere the number of knots +c in one direction (say nt) has reached the value of its upper bound +c (ntest), then from that moment on all subsequent knots are added +c in the other (phi) direction. this may indicate that the value of +c ntest is too small. on the other hand, it gives the user the option +c of limiting the number of knots the routine locates in any direction +c for example, by setting ntest=8 (the lowest allowable value for +c ntest), the user can indicate that he wants an approximation which +c is a cubic polynomial in the variable teta. +c +c other subroutines required: +c fpback,fpbspl,fpsphe,fpdisc,fpgivs,fprank,fprati,fprota,fporde, +c fprpsp +c +c references: +c dierckx p. : algorithms for smoothing data on the sphere with tensor +c product splines, computing 32 (1984) 319-342. +c dierckx p. : algorithms for smoothing data on the sphere with tensor +c product splines, report tw62, dept. computer science, +c k.u.leuven, 1983. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : july 1983 +c latest update : march 1989 +c +c .. +c ..scalar arguments.. + real*8 s,eps,fp + integer iopt,m,ntest,npest,nt,np,lwrk1,lwrk2,kwrk,ier +c ..array arguments.. + real*8 teta(m),phi(m),r(m),w(m),tt(ntest),tp(npest), + * c((ntest-4)*(npest-4)),wrk1(lwrk1),wrk2(lwrk2) + integer iwrk(kwrk) +c ..local scalars.. + real*8 tol,pi,pi2,one + integer i,ib1,ib3,ki,kn,kwest,la,lbt,lcc,lcs,lro,j, + * lbp,lco,lf,lff,lfp,lh,lq,lst,lsp,lwest,maxit,ncest,ncc,ntt, + * npp,nreg,nrint,ncof,nt4,np4 +c ..function references.. + real*8 atan +c ..subroutine references.. +c fpsphe +c .. +c set constants + one = 0.1e+01 +c we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid,control is immediately repassed to the calling program. + ier = 10 + if(eps.le.0. .or. eps.ge.1.) go to 80 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 80 + if(m.lt.2) go to 80 + if(ntest.lt.8 .or. npest.lt.8) go to 80 + nt4 = ntest-4 + np4 = npest-4 + ncest = nt4*np4 + ntt = ntest-7 + npp = npest-7 + ncc = 6+npp*(ntt-1) + nrint = ntt+npp + nreg = ntt*npp + ncof = 6+3*npp + ib1 = 4*npp + ib3 = ib1+3 + if(ncof.gt.ib1) ib1 = ncof + if(ncof.gt.ib3) ib3 = ncof + lwest = 185+52*npp+10*ntt+14*ntt*npp+8*(m+(ntt-1)*npp**2) + kwest = m+nreg + if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 80 + if(iopt.gt.0) go to 60 + pi = atan(one)*4 + pi2 = pi+pi + do 20 i=1,m + if(w(i).le.0.) go to 80 + if(teta(i).lt.0. .or. teta(i).gt.pi) go to 80 + if(phi(i) .lt.0. .or. phi(i).gt.pi2) go to 80 + 20 continue + if(iopt.eq.0) go to 60 + ntt = nt-8 + if(ntt.lt.0 .or. nt.gt.ntest) go to 80 + if(ntt.eq.0) go to 40 + tt(4) = 0. + do 30 i=1,ntt + j = i+4 + if(tt(j).le.tt(j-1) .or. tt(j).ge.pi) go to 80 + 30 continue + 40 npp = np-8 + if(npp.lt.1 .or. np.gt.npest) go to 80 + tp(4) = 0. + do 50 i=1,npp + j = i+4 + if(tp(j).le.tp(j-1) .or. tp(j).ge.pi2) go to 80 + 50 continue + go to 70 + 60 if(s.lt.0.) go to 80 + 70 ier = 0 +c we partition the working space and determine the spline approximation + kn = 1 + ki = kn+m + lq = 2 + la = lq+ncc*ib3 + lf = la+ncc*ib1 + lff = lf+ncc + lfp = lff+ncest + lco = lfp+nrint + lh = lco+nrint + lbt = lh+ib3 + lbp = lbt+5*ntest + lro = lbp+5*npest + lcc = lro+npest + lcs = lcc+npest + lst = lcs+npest + lsp = lst+m*4 + call fpsphe(iopt,m,teta,phi,r,w,s,ntest,npest,eps,tol,maxit, + * ib1,ib3,ncest,ncc,nrint,nreg,nt,tt,np,tp,c,fp,wrk1(1),wrk1(lfp), + * wrk1(lco),wrk1(lf),wrk1(lff),wrk1(lro),wrk1(lcc),wrk1(lcs), + * wrk1(la),wrk1(lq),wrk1(lbt),wrk1(lbp),wrk1(lst),wrk1(lsp), + * wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier) + 80 return + end + diff --git a/fitpack/splder.f b/fitpack/splder.f new file mode 100644 index 0000000..fff028c --- /dev/null +++ b/fitpack/splder.f @@ -0,0 +1,193 @@ + recursive subroutine splder(t,n,c,nc,k,nu,x,y,m,e,wrk,ier) + implicit none +c subroutine splder evaluates in a number of points x(i),i=1,2,...,m +c the derivative of order nu of a spline s(x) of degree k,given in +c its b-spline representation. +c +c calling sequence: +c call splder(t,n,c,nc,k,nu,x,y,m,e,wrk,ier) +c +c input parameters: +c t : array,length n, which contains the position of the knots. +c n : integer, giving the total number of knots of s(x). +c c : array,length nc, containing the b-spline coefficients. +c the length of the array, nc >= n - k -1. +c further coefficients are ignored. +c k : integer, giving the degree of s(x). +c nu : integer, specifying the order of the derivative. 0<=nu<=k +c x : array,length m, which contains the points where the deriv- +c ative of s(x) must be evaluated. +c m : integer, giving the number of points where the derivative +c of s(x) must be evaluated +c e : integer, if 0 the spline is extrapolated from the end +c spans for points not in the support, if 1 the spline +c evaluates to zero for those points, and if 2 ier is set to +c 1 and the subroutine returns. +c wrk : real array of dimension n. used as working space. +c +c output parameters: +c y : array,length m, giving the value of the derivative of s(x) +c at the different points. +c ier : error flag +c ier = 0 : normal return +c ier = 1 : argument out of bounds and e == 2 +c ier =10 : invalid input data (see restrictions) +c +c restrictions: +c 0 <= nu <= k +c m >= 1 +c t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1. +c +c other subroutines required: fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c++ pearu: 13 aug 20003 +c++ - disabled cliping x values to interval [min(t),max(t)] +c++ - removed the restriction of the orderness of x values +c++ - fixed initialization of sp to double precision value +c +c ..scalar arguments.. + integer n,nc,k,nu,m,e,ier +c ..array arguments.. + real*8 t(n),c(nc),x(m),y(m),wrk(n) +c ..local scalars.. + integer i,j,kk,k1,k2,l,ll,l1,l2,nk1,nk2,nn + real*8 ak,arg,fac,sp,tb,te +c++.. + integer k3 +c..++ +c ..local arrays .. + real*8 h(6) +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + if(nu.lt.0 .or. nu.gt.k) go to 200 +c-- if(m-1) 200,30,10 +c++.. + if(m.lt.1) go to 200 +c..++ +c-- 10 do 20 i=2,m +c-- if(x(i).lt.x(i-1)) go to 200 +c-- 20 continue + ier = 0 +c fetch tb and te, the boundaries of the approximation interval. + k1 = k+1 + k3 = k1+1 + nk1 = n-k1 + tb = t(k1) + te = t(nk1+1) +c the derivative of order nu of a spline of degree k is a spline of +c degree k-nu,the b-spline coefficients wrk(i) of which can be found +c using the recurrence scheme of de boor. + l = 1 + kk = k + nn = n + do 40 i=1,nk1 + wrk(i) = c(i) + 40 continue + if(nu.eq.0) go to 100 + nk2 = nk1 + do 60 j=1,nu + ak = kk + nk2 = nk2-1 + l1 = l + do 50 i=1,nk2 + l1 = l1+1 + l2 = l1+kk + fac = t(l2)-t(l1) + if(fac.le.0.) go to 50 + wrk(i) = ak*(wrk(i+1)-wrk(i))/fac + 50 continue + l = l+1 + kk = kk-1 + 60 continue + if(kk.ne.0) go to 100 +c if nu=k the derivative is a piecewise constant function + j = 1 + do 90 i=1,m + arg = x(i) +c++.. +c check if arg is in the support + if (arg .lt. tb .or. arg .gt. te) then + if (e .eq. 0) then + goto 65 + else if (e .eq. 1) then + y(i) = 0 + goto 90 + else if (e .eq. 2) then + ier = 1 + goto 200 + endif + endif +c search for knot interval t(l) <= arg < t(l+1) + 65 if(arg.ge.t(l) .or. l+1.eq.k3) go to 70 + l1 = l + l = l-1 + j = j-1 + go to 65 +c..++ + 70 if(arg.lt.t(l+1) .or. l.eq.nk1) go to 80 + l = l+1 + j = j+1 + go to 70 + 80 y(i) = wrk(j) + 90 continue + go to 200 + + 100 l = k1 + l1 = l+1 + k2 = k1-nu +c main loop for the different points. + do 180 i=1,m +c fetch a new x-value arg. + arg = x(i) +c check if arg is in the support + if (arg .lt. tb .or. arg .gt. te) then + if (e .eq. 0) then + goto 135 + else if (e .eq. 1) then + y(i) = 0 + goto 180 + else if (e .eq. 2) then + ier = 1 + goto 200 + endif + endif +c search for knot interval t(l) <= arg < t(l+1) + 135 if(arg.ge.t(l) .or. l1.eq.k3) go to 140 + l1 = l + l = l-1 + go to 135 +c..++ + 140 if(arg.lt.t(l1) .or. l.eq.nk1) go to 150 + l = l1 + l1 = l+1 + go to 140 +c evaluate the non-zero b-splines of degree k-nu at arg. + 150 call fpbspl(t,n,kk,arg,l,h) +c find the value of the derivative at x=arg. + sp = 0.0d0 + ll = l-k1 + do 160 j=1,k2 + ll = ll+1 + sp = sp+wrk(ll)*h(j) + 160 continue + y(i) = sp + 180 continue + 200 return + end diff --git a/fitpack/splev.f b/fitpack/splev.f new file mode 100644 index 0000000..4ee7cdf --- /dev/null +++ b/fitpack/splev.f @@ -0,0 +1,139 @@ + recursive subroutine splev(t,n,c,nc,k,x,y,m,e,ier) +c subroutine splev evaluates in a number of points x(i),i=1,2,...,m +c a spline s(x) of degree k, given in its b-spline representation. +c +c calling sequence: +c call splev(t,n,c,nc,k,x,y,m,e,ier) +c +c input parameters: +c t : array,length n, which contains the position of the knots. +c n : integer, giving the total number of knots of s(x). +c c : array,length nc, containing the b-spline coefficients. +c the length of the array, nc >= n - k -1. +c further coefficients are ignored. +c k : integer, giving the degree of s(x). +c x : array,length m, which contains the points where s(x) must +c be evaluated. +c m : integer, giving the number of points where s(x) must be +c evaluated. +c e : integer, if 0 the spline is extrapolated from the end +c spans for points not in the support, if 1 the spline +c evaluates to zero for those points, if 2 ier is set to +c 1 and the subroutine returns, and if 3 the spline evaluates +c to the value of the nearest boundary point. +c +c output parameter: +c y : array,length m, giving the value of s(x) at the different +c points. +c ier : error flag +c ier = 0 : normal return +c ier = 1 : argument out of bounds and e == 2 +c ier =10 : invalid input data (see restrictions) +c +c restrictions: +c m >= 1 +c-- t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1. +c +c other subroutines required: fpbspl. +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c++ pearu: 11 aug 2003 +c++ - disabled cliping x values to interval [min(t),max(t)] +c++ - removed the restriction of the orderness of x values +c++ - fixed initialization of sp to double precision value +c +c ..scalar arguments.. + integer n, k, m, e, ier +c ..array arguments.. + real*8 t(n), c(nc), x(m), y(m) +c ..local scalars.. + integer i, j, k1, l, ll, l1, nk1 +c++.. + integer k2 +c..++ + real*8 arg, sp, tb, te +c ..local array.. + real*8 h(20) +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 +c-- if(m-1) 100,30,10 +c++.. + if (m .lt. 1) go to 100 +c..++ +c-- 10 do 20 i=2,m +c-- if(x(i).lt.x(i-1)) go to 100 +c-- 20 continue + ier = 0 +c fetch tb and te, the boundaries of the approximation interval. + k1 = k + 1 +c++.. + k2 = k1 + 1 +c..++ + nk1 = n - k1 + tb = t(k1) + te = t(nk1 + 1) + l = k1 + l1 = l + 1 +c main loop for the different points. + do 80 i = 1, m +c fetch a new x-value arg. + arg = x(i) +c check if arg is in the support + if (arg .lt. tb .or. arg .gt. te) then + if (e .eq. 0) then + goto 35 + else if (e .eq. 1) then + y(i) = 0 + goto 80 + else if (e .eq. 2) then + ier = 1 + goto 100 + else if (e .eq. 3) then + if (arg .lt. tb) then + arg = tb + else + arg = te + endif + endif + endif +c search for knot interval t(l) <= arg < t(l+1) +c++.. + 35 if (arg .ge. t(l) .or. l1 .eq. k2) go to 40 + l1 = l + l = l - 1 + go to 35 +c..++ + 40 if(arg .lt. t(l1) .or. l .eq. nk1) go to 50 + l = l1 + l1 = l + 1 + go to 40 +c evaluate the non-zero b-splines at arg. + 50 call fpbspl(t, n, k, arg, l, h) +c find the value of s(x) at x=arg. + sp = 0.0d0 + ll = l - k1 + do 60 j = 1, k1 + ll = ll + 1 + sp = sp + c(ll)*h(j) + 60 continue + y(i) = sp + 80 continue + 100 return + end diff --git a/fitpack/splint.f b/fitpack/splint.f new file mode 100644 index 0000000..02b00da --- /dev/null +++ b/fitpack/splint.f @@ -0,0 +1,62 @@ + recursive function splint(t,n,c,nc,k,a,b,wrk) result(splint_res) + implicit none + real*8 :: splint_res +c function splint calculates the integral of a spline function s(x) +c of degree k, which is given in its normalized b-spline representation +c +c calling sequence: +c aint = splint(t,n,c,k,a,b,wrk) +c +c input parameters: +c t : array,length n,which contains the position of the knots +c of s(x). +c n : integer, giving the total number of knots of s(x). +c c : array,length nc, containing the b-spline coefficients. +c the length of the array, nc >= n - k -1. +c further coefficients are ignored. +c k : integer, giving the degree of s(x). +c a,b : real values, containing the end points of the integration +c interval. s(x) is considered to be identically zero outside +c the interval (t(k+1),t(n-k)). +c +c output parameter: +c aint : real, containing the integral of s(x) between a and b. +c wrk : real array, length n. used as working space +c on output, wrk will contain the integrals of the normalized +c b-splines defined on the set of knots. +c +c other subroutines required: fpintb. +c +c references : +c gaffney p.w. : the calculation of indefinite integrals of b-splines +c j. inst. maths applics 17 (1976) 37-41. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + real*8 a,b + integer n,k, nc +c ..array arguments.. + real*8 t(n),c(nc),wrk(n) +c ..local scalars.. + integer i,nk1 +c .. + nk1 = n-k-1 +c calculate the integrals wrk(i) of the normalized b-splines +c ni,k+1(x), i=1,2,...nk1. + call fpintb(t,n,wrk,nk1,a,b) +c calculate the integral of s(x). + splint_res = 0.0d0 + do 10 i=1,nk1 + splint_res = splint_res+c(i)*wrk(i) + 10 continue + return + end diff --git a/fitpack/sproot.f b/fitpack/sproot.f new file mode 100644 index 0000000..c9b564b --- /dev/null +++ b/fitpack/sproot.f @@ -0,0 +1,186 @@ + recursive subroutine sproot(t,n,c,nc,zero,mest,m,ier) + implicit none +c subroutine sproot finds the zeros of a cubic spline s(x),which is +c given in its normalized b-spline representation. +c +c calling sequence: +c call sproot(t,n,c,nc,zero,mest,m,ier) +c +c input parameters: +c t : real array,length n, containing the knots of s(x). +c n : integer, containing the number of knots. n>=8 +c c : array,length nc, containing the b-spline coefficients. +c the length of the array, nc >= n - k -1. +c further coefficients are ignored. +c mest : integer, specifying the dimension of array zero. +c +c output parameters: +c zero : real array,length mest, containing the zeros of s(x). +c m : integer,giving the number of zeros. +c ier : error flag: +c ier = 0: normal return. +c ier = 1: the number of zeros exceeds mest. +c ier =10: invalid input data (see restrictions). +c +c other subroutines required: fpcuro +c +c restrictions: +c 1) n>= 8. +c 2) t(4) < t(5) < ... < t(n-4) < t(n-3). +c t(1) <= t(2) <= t(3) <= t(4) +c t(n-3) <= t(n-2) <= t(n-1) <= t(n) +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + integer n,nc,mest,m,ier +c ..array arguments.. + real*8 t(n),c(nc),zero(mest) +c ..local scalars.. + integer i,j,j1,l,n4 + real*8 ah,a0,a1,a2,a3,bh,b0,b1,c1,c2,c3,c4,c5,d4,d5,h1,h2, + * three,two,t1,t2,t3,t4,t5,zz + logical z0,z1,z2,z3,z4,nz0,nz1,nz2,nz3,nz4 +c ..local array.. + real*8 y(3) +c .. +c set some constants + two = 0.2d+01 + three = 0.3d+01 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + n4 = n-4 + ier = 10 + if(n.lt.8) go to 800 + j = n + do 10 i=1,3 + if(t(i).gt.t(i+1)) go to 800 + if(t(j).lt.t(j-1)) go to 800 + j = j-1 + 10 continue + do 20 i=4,n4 + if(t(i).ge.t(i+1)) go to 800 + 20 continue +c the problem considered reduces to finding the zeros of the cubic +c polynomials pl(x) which define the cubic spline in each knot +c interval t(l)<=x<=t(l+1). a zero of pl(x) is also a zero of s(x) on +c the condition that it belongs to the knot interval. +c the cubic polynomial pl(x) is determined by computing s(t(l)), +c s'(t(l)),s(t(l+1)) and s'(t(l+1)). in fact we only have to compute +c s(t(l+1)) and s'(t(l+1)); because of the continuity conditions of +c splines and their derivatives, the value of s(t(l)) and s'(t(l)) +c is already known from the foregoing knot interval. + ier = 0 +c evaluate some constants for the first knot interval + h1 = t(4)-t(3) + h2 = t(5)-t(4) + t1 = t(4)-t(2) + t2 = t(5)-t(3) + t3 = t(6)-t(4) + t4 = t(5)-t(2) + t5 = t(6)-t(3) +c calculate a0 = s(t(4)) and ah = s'(t(4)). + c1 = c(1) + c2 = c(2) + c3 = c(3) + c4 = (c2-c1)/t4 + c5 = (c3-c2)/t5 + d4 = (h2*c1+t1*c2)/t4 + d5 = (t3*c2+h1*c3)/t5 + a0 = (h2*d4+h1*d5)/t2 + ah = three*(h2*c4+h1*c5)/t2 + z1 = .true. + if(ah.lt.0.0d0) z1 = .false. + nz1 = .not.z1 + m = 0 +c main loop for the different knot intervals. + do 300 l=4,n4 +c evaluate some constants for the knot interval t(l) <= x <= t(l+1). + h1 = h2 + h2 = t(l+2)-t(l+1) + t1 = t2 + t2 = t3 + t3 = t(l+3)-t(l+1) + t4 = t5 + t5 = t(l+3)-t(l) +c find a0 = s(t(l)), ah = s'(t(l)), b0 = s(t(l+1)) and bh = s'(t(l+1)). + c1 = c2 + c2 = c3 + c3 = c(l) + c4 = c5 + c5 = (c3-c2)/t5 + d4 = (h2*c1+t1*c2)/t4 + d5 = (h1*c3+t3*c2)/t5 + b0 = (h2*d4+h1*d5)/t2 + bh = three*(h2*c4+h1*c5)/t2 +c calculate the coefficients a0,a1,a2 and a3 of the cubic polynomial +c pl(x) = ql(y) = a0+a1*y+a2*y**2+a3*y**3 ; y = (x-t(l))/(t(l+1)-t(l)). + a1 = ah*h1 + b1 = bh*h1 + a2 = three*(b0-a0)-b1-two*a1 + a3 = two*(a0-b0)+b1+a1 +c test whether or not pl(x) could have a zero in the range +c t(l) <= x <= t(l+1). + z3 = .true. + if(b1.lt.0.0d0) z3 = .false. + nz3 = .not.z3 + if(a0*b0.le.0.0d0) go to 100 + z0 = .true. + if(a0.lt.0.0d0) z0 = .false. + nz0 = .not.z0 + z2 = .true. + if(a2.lt.0.) z2 = .false. + nz2 = .not.z2 + z4 = .true. + if(3.0d0*a3+a2.lt.0.0d0) z4 = .false. + nz4 = .not.z4 + if(.not.((z0.and.(nz1.and.(z3.or.z2.and.nz4).or.nz2.and. + * z3.and.z4).or.nz0.and.(z1.and.(nz3.or.nz2.and.z4).or.z2.and. + * nz3.and.nz4))))go to 200 +c find the zeros of ql(y). + 100 call fpcuro(a3,a2,a1,a0,y,j) + if(j.eq.0) go to 200 +c find which zeros of pl(x) are zeros of s(x). + do 150 i=1,j + if(y(i).lt.0.0d0 .or. y(i).gt.1.0d0) go to 150 +c test whether the number of zeros of s(x) exceeds mest. + if(m.ge.mest) go to 700 + m = m+1 + zero(m) = t(l)+h1*y(i) + 150 continue + 200 a0 = b0 + ah = bh + z1 = z3 + nz1 = nz3 + 300 continue +c the zeros of s(x) are arranged in increasing order. + if(m.lt.2) go to 800 + do 400 i=2,m + j = i + 350 j1 = j-1 + if(j1.eq.0) go to 400 + if(zero(j).ge.zero(j1)) go to 400 + zz = zero(j) + zero(j) = zero(j1) + zero(j1) = zz + j = j1 + go to 350 + 400 continue + j = m + m = 1 + do 500 i=2,j + if(zero(i).eq.zero(m)) go to 500 + m = m+1 + zero(m) = zero(i) + 500 continue + go to 800 + 700 ier = 1 + 800 return + end diff --git a/fitpack/surev.f b/fitpack/surev.f new file mode 100644 index 0000000..1fb184f --- /dev/null +++ b/fitpack/surev.f @@ -0,0 +1,107 @@ + recursive subroutine surev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,mf, + * wrk,lwrk,iwrk,kwrk,ier) + implicit none +c subroutine surev evaluates on a grid (u(i),v(j)),i=1,...,mu; j=1,... +c ,mv a bicubic spline surface of dimension idim, given in the +c b-spline representation. +c +c calling sequence: +c call surev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,mf,wrk,lwrk, +c * iwrk,kwrk,ier) +c +c input parameters: +c idim : integer, specifying the dimension of the spline surface. +c tu : real array, length nu, which contains the position of the +c knots in the u-direction. +c nu : integer, giving the total number of knots in the u-direction +c tv : real array, length nv, which contains the position of the +c knots in the v-direction. +c nv : integer, giving the total number of knots in the v-direction +c c : real array, length (nu-4)*(nv-4)*idim, which contains the +c b-spline coefficients. +c u : real array of dimension (mu). +c before entry u(i) must be set to the u co-ordinate of the +c i-th grid point along the u-axis. +c tu(4)<=u(i-1)<=u(i)<=tu(nu-3), i=2,...,mu. +c mu : on entry mu must specify the number of grid points along +c the u-axis. mu >=1. +c v : real array of dimension (mv). +c before entry v(j) must be set to the v co-ordinate of the +c j-th grid point along the v-axis. +c tv(4)<=v(j-1)<=v(j)<=tv(nv-3), j=2,...,mv. +c mv : on entry mv must specify the number of grid points along +c the v-axis. mv >=1. +c mf : on entry, mf must specify the dimension of the array f. +c mf >= mu*mv*idim +c wrk : real array of dimension lwrk. used as workspace. +c lwrk : integer, specifying the dimension of wrk. +c lwrk >= 4*(mu+mv) +c iwrk : integer array of dimension kwrk. used as workspace. +c kwrk : integer, specifying the dimension of iwrk. kwrk >= mu+mv. +c +c output parameters: +c f : real array of dimension (mf). +c on successful exit f(mu*mv*(l-1)+mv*(i-1)+j) contains the +c l-th co-ordinate of the bicubic spline surface at the +c point (u(i),v(j)),l=1,...,idim,i=1,...,mu;j=1,...,mv. +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c mu >=1, mv >=1, lwrk>=4*(mu+mv), kwrk>=mu+mv , mf>=mu*mv*idim +c tu(4) <= u(i-1) <= u(i) <= tu(nu-3), i=2,...,mu +c tv(4) <= v(j-1) <= v(j) <= tv(nv-3), j=2,...,mv +c +c other subroutines required: +c fpsuev,fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer idim,nu,nv,mu,mv,mf,lwrk,kwrk,ier +c ..array arguments.. + integer iwrk(kwrk) + real*8 tu(nu),tv(nv),c((nu-4)*(nv-4)*idim),u(mu),v(mv),f(mf), + * wrk(lwrk) +c ..local scalars.. + integer i,muv +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + if(mf.lt.mu*mv*idim) go to 100 + muv = mu+mv + if(lwrk.lt.4*muv) go to 100 + if(kwrk.lt.muv) go to 100 + if (mu.lt.1) go to 100 + if (mu.eq.1) go to 30 + go to 10 + 10 do 20 i=2,mu + if(u(i).lt.u(i-1)) go to 100 + 20 continue + 30 if (mv.lt.1) go to 100 + if (mv.eq.1) go to 60 + go to 40 + 40 do 50 i=2,mv + if(v(i).lt.v(i-1)) go to 100 + 50 continue + 60 ier = 0 + call fpsuev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,wrk(1),wrk(4*mu+1), + * iwrk(1),iwrk(mu+1)) + 100 return + end diff --git a/fitpack/surfit.f b/fitpack/surfit.f new file mode 100644 index 0000000..0dcc6e7 --- /dev/null +++ b/fitpack/surfit.f @@ -0,0 +1,414 @@ + recursive subroutine surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s, + * nxest,nyest,nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2, + * iwrk,kwrk,ier) + implicit none +c given the set of data points (x(i),y(i),z(i)) and the set of positive +c numbers w(i),i=1,...,m, subroutine surfit determines a smooth bivar- +c iate spline approximation s(x,y) of degrees kx and ky on the rect- +c angle xb <= x <= xe, yb <= y <= ye. +c if iopt = -1 surfit calculates the weighted least-squares spline +c according to a given set of knots. +c if iopt >= 0 the total numbers nx and ny of these knots and their +c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic- +c ally by the routine. the smoothness of s(x,y) is then achieved by +c minimalizing the discontinuity jumps in the derivatives of s(x,y) +c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1). +c the amounth of smoothness is determined by the condition that f(p) = +c sum ((w(i)*(z(i)-s(x(i),y(i))))**2) be <= s, with s a given non-neg- +c ative constant, called the smoothing factor. +c the fit is given in the b-spline representation (b-spline coefficients +c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval- +c uated by means of subroutine bispev. +c +c calling sequence: +c call surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest, +c * nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a weighted +c least-squares spline (iopt=-1) or a smoothing spline (iopt=0 +c or 1) must be determined. +c if iopt=0 the routine will start with an initial set of knots +c tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i= +c 1,...,ky+1. if iopt=1 the routine will continue with the set +c of knots found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately pre- +c ceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m >= (kx+1)*(ky+1). unchanged on exit. +c x : real array of dimension at least (m). +c y : real array of dimension at least (m). +c z : real array of dimension at least (m). +c before entry, x(i),y(i),z(i) must be set to the co-ordinates +c of the i-th data point, for i=1,...,m. the order of the data +c points is immaterial. unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) must +c be set to the i-th value in the set of weights. the w(i) must +c be strictly positive. unchanged on exit. +c xb,xe : real values. on entry xb,xe,yb and ye must specify the bound- +c yb,ye aries of the rectangular approximation domain. +c xb<=x(i)<=xe,yb<=y(i)<=ye,i=1,...,m. unchanged on exit. +c kx,ky : integer values. on entry kx and ky must specify the degrees +c of the spline. 1<=kx,ky<=5. it is recommended to use bicubic +c (kx=ky=3) splines. unchanged on exit. +c s : real. on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments +c nxest : integer. unchanged on exit. +c nyest : integer. unchanged on exit. +c on entry, nxest and nyest must specify an upper bound for the +c number of knots required in the x- and y-directions respect. +c these numbers will also determine the storage space needed by +c the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1). +c in most practical situation nxest = kx+1+sqrt(m/2), nyest = +c ky+1+sqrt(m/2) will be sufficient. see also further comments. +c nmax : integer. on entry nmax must specify the actual dimension of +c the arrays tx and ty. nmax >= nxest, nmax >=nyest. +c unchanged on exit. +c eps : real. +c on entry, eps must specify a threshold for determining the +c effective rank of an over-determined linear system of equat- +c ions. 0 < eps < 1. if the number of decimal digits in the +c computer representation of a real number is q, then 10**(-q) +c is a suitable value for eps in most practical applications. +c unchanged on exit. +c nx : integer. +c unless ier=10 (in case iopt >=0), nx will contain the total +c number of knots with respect to the x-variable, of the spline +c approximation returned. if the computation mode iopt=1 is +c used, the value of nx should be left unchanged between sub- +c sequent calls. +c in case iopt=-1, the value of nx should be specified on entry +c tx : real array of dimension nmax. +c on successful exit, this array will contain the knots of the +c spline with respect to the x-variable, i.e. the position of +c the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the +c position of the additional knots tx(1)=...=tx(kx+1)=xb and +c tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat. +c if the computation mode iopt=1 is used, the values of tx(1), +c ...,tx(nx) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values tx(kx+2), +c ...tx(nx-kx-1) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c ny : integer. +c unless ier=10 (in case iopt >=0), ny will contain the total +c number of knots with respect to the y-variable, of the spline +c approximation returned. if the computation mode iopt=1 is +c used, the value of ny should be left unchanged between sub- +c sequent calls. +c in case iopt=-1, the value of ny should be specified on entry +c ty : real array of dimension nmax. +c on successful exit, this array will contain the knots of the +c spline with respect to the y-variable, i.e. the position of +c the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the +c position of the additional knots ty(1)=...=ty(ky+1)=yb and +c ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat. +c if the computation mode iopt=1 is used, the values of ty(1), +c ...,ty(ny) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values ty(ky+2), +c ...ty(ny-ky-1) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1). +c on successful exit, c contains the coefficients of the spline +c approximation s(x,y) +c fp : real. unless ier=10, fp contains the weighted sum of +c squared residuals of the spline approximation returned. +c wrk1 : real array of dimension (lwrk1). used as workspace. +c if the computation mode iopt=1 is used the value of wrk1(1) +c should be left unchanged between subsequent calls. +c on exit wrk1(2),wrk1(3),...,wrk1(1+(nx-kx-1)*(ny-ky-1)) will +c contain the values d(i)/max(d(i)),i=1,...,(nx-kx-1)*(ny-ky-1) +c with d(i) the i-th diagonal element of the reduced triangular +c matrix for calculating the b-spline coefficients. it includes +c those elements whose square is less than eps,which are treat- +c ed as 0 in the case of presumed rank deficiency (ier<-2). +c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of +c the array wrk1 as declared in the calling (sub)program. +c lwrk1 must not be too small. let +c u = nxest-kx-1, v = nyest-ky-1, km = max(kx,ky)+1, +c ne = max(nxest,nyest), bx = kx*v+ky+1, by = ky*u+kx+1, +c if(bx.le.by) b1 = bx, b2 = b1+v-ky +c if(bx.gt.by) b1 = by, b2 = b1+u-kx then +c lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1 +c wrk2 : real array of dimension (lwrk2). used as workspace, but +c only in the case a rank deficient system is encountered. +c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of +c the array wrk2 as declared in the calling (sub)program. +c lwrk2 > 0 . a save upper boundfor lwrk2 = u*v*(b2+1)+b2 +c where u,v and b2 are as above. if there are enough data +c points, scattered uniformly over the approximation domain +c and if the smoothing factor s is not too small, there is a +c good chance that this extra workspace is not needed. a lot +c of memory might therefore be saved by setting lwrk2=1. +c (see also ier > 10) +c iwrk : integer array of dimension (kwrk). used as workspace. +c kwrk : integer. on entry kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. +c kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1). +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c spline (fp=0). +c ier=-2 : normal return. the spline returned is the weighted least- +c squares polynomial of degrees kx and ky. in this extreme +c case fp gives the upper bound for the smoothing factor s. +c ier<-2 : warning. the coefficients of the spline returned have been +c computed as the minimal norm least-squares solution of a +c (numerically) rank deficient system. (-ier) gives the rank. +c especially if the rank deficiency which can be computed as +c (nx-kx-1)*(ny-ky-1)+ier, is large the results may be inac- +c curate. they could also seriously depend on the value of +c eps. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameters nxest and +c nyest. +c probably causes : nxest or nyest too small. if these param- +c eters are already large, it may also indicate that s is +c too small +c the approximation returned is the weighted least-squares +c spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration process for finding a smoothing spline with +c fp = s. probably causes : s too small or badly chosen eps. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=4 : error. no more knots can be added because the number of +c b-spline coefficients (nx-kx-1)*(ny-ky-1) already exceeds +c the number of data points m. +c probably causes : either s or m too small. +c the approximation returned is the weighted least-squares +c spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=5 : error. no more knots can be added because the additional +c knot would (quasi) coincide with an old one. +c probably causes : s too small or too large a weight to an +c inaccurate data point. +c the approximation returned is the weighted least-squares +c spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 1<=kx,ky<=5, m>=(kx+1)*(ky+1), nxest>=2*kx+2, +c nyest>=2*ky+2, 0=nxest, nmax>=nyest, +c xb<=x(i)<=xe, yb<=y(i)<=ye, w(i)>0, i=1,...,m +c lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1 +c kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1) +c if iopt=-1: 2*kx+2<=nx<=nxest +c xb=0: s>=0 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c ier>10 : error. lwrk2 is too small, i.e. there is not enough work- +c space for computing the minimal least-squares solution of +c a rank deficient system of linear equations. ier gives the +c requested value for lwrk2. there is no approximation re- +c turned but, having saved the information contained in nx, +c ny,tx,ty,wrk1, and having adjusted the value of lwrk2 and +c the dimension of the array wrk2 accordingly, the user can +c continue at the point the program was left, by calling +c surfit with iopt=1. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the weighted least-squares polynomial (degrees kx,ky)if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c z(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in z(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the least-squares +c polynomial and the corresponding upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximation shows more detail) to obtain closer fits. +c to choose s very small is strongly discouraged. this considerably +c increases computation time and memory requirements. it may also +c cause rank-deficiency (ier<-2) and endager numerical stability. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if surfit is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. if the computation mode iopt=1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c surfit once more with the selected value for s but now with iopt=0. +c indeed, surfit may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c the number of knots may also depend on the upper bounds nxest and +c nyest. indeed, if at a certain stage in surfit the number of knots +c in one direction (say nx) has reached the value of its upper bound +c (nxest), then from that moment on all subsequent knots are added +c in the other (y) direction. this may indicate that the value of +c nxest is too small. on the other hand, it gives the user the option +c of limiting the number of knots the routine locates in any direction +c for example, by setting nxest=2*kx+2 (the lowest allowable value for +c nxest), the user can indicate that he wants an approximation which +c is a simple polynomial of degree kx in the variable x. +c +c other subroutines required: +c fpback,fpbspl,fpsurf,fpdisc,fpgivs,fprank,fprati,fprota,fporde +c +c references: +c dierckx p. : an algorithm for surface fitting with spline functions +c ima j. numer. anal. 1 (1981) 267-283. +c dierckx p. : an algorithm for surface fitting with spline functions +c report tw50, dept. computer science,k.u.leuven, 1980. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + real*8 xb,xe,yb,ye,s,eps,fp + integer iopt,m,kx,ky,nxest,nyest,nmax,nx,ny,lwrk1,lwrk2,kwrk,ier +c ..array arguments.. + real*8 x(m),y(m),z(m),w(m),tx(nmax),ty(nmax), + * c((nxest-kx-1)*(nyest-ky-1)),wrk1(lwrk1),wrk2(lwrk2) + integer iwrk(kwrk) +c ..local scalars.. + real*8 tol + integer i,ib1,ib3,jb1,ki,kmax,km1,km2,kn,kwest,kx1,ky1,la,lbx, + * lby,lco,lf,lff,lfp,lh,lq,lsx,lsy,lwest,maxit,ncest,nest,nek, + * nminx,nminy,nmx,nmy,nreg,nrint,nxk,nyk +c ..function references.. + integer max0 +c ..subroutine references.. +c fpsurf +c .. +c we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid,control is immediately repassed to the calling program. + ier = 10 + if(eps.le.0. .or. eps.ge.1.) go to 71 + if(kx.le.0 .or. kx.gt.5) go to 71 + kx1 = kx+1 + if(ky.le.0 .or. ky.gt.5) go to 71 + ky1 = ky+1 + kmax = max0(kx,ky) + km1 = kmax+1 + km2 = km1+1 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 71 + if(m.lt.(kx1*ky1)) go to 71 + nminx = 2*kx1 + if(nxest.lt.nminx .or. nxest.gt.nmax) go to 71 + nminy = 2*ky1 + if(nyest.lt.nminy .or. nyest.gt.nmax) go to 71 + nest = max0(nxest,nyest) + nxk = nxest-kx1 + nyk = nyest-ky1 + ncest = nxk*nyk + nmx = nxest-nminx+1 + nmy = nyest-nminy+1 + nrint = nmx+nmy + nreg = nmx*nmy + ib1 = kx*nyk+ky1 + jb1 = ky*nxk+kx1 + ib3 = kx1*nyk+1 + if(ib1.le.jb1) go to 10 + ib1 = jb1 + ib3 = ky1*nxk+1 + 10 lwest = ncest*(2+ib1+ib3)+2*(nrint+nest*km2+m*km1)+ib3 + kwest = m+nreg + if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 71 + if(xb.ge.xe .or. yb.ge.ye) go to 71 + do 20 i=1,m + if(w(i).le.0.) go to 70 + if(x(i).lt.xb .or. x(i).gt.xe) go to 71 + if(y(i).lt.yb .or. y(i).gt.ye) go to 71 + 20 continue + if(iopt.ge.0) go to 50 + if(nx.lt.nminx .or. nx.gt.nxest) go to 71 + nxk = nx-kx1 + tx(kx1) = xb + tx(nxk+1) = xe + do 30 i=kx1,nxk + if(tx(i+1).le.tx(i)) go to 72 + 30 continue + if(ny.lt.nminy .or. ny.gt.nyest) go to 71 + nyk = ny-ky1 + ty(ky1) = yb + ty(nyk+1) = ye + do 40 i=ky1,nyk + if(ty(i+1).le.ty(i)) go to 73 + 40 continue + go to 60 + 50 if(s.lt.0.) go to 71 + 60 ier = 0 +c we partition the working space and determine the spline approximation + kn = 1 + ki = kn+m + lq = 2 + la = lq+ncest*ib3 + lf = la+ncest*ib1 + lff = lf+ncest + lfp = lff+ncest + lco = lfp+nrint + lh = lco+nrint + lbx = lh+ib3 + nek = nest*km2 + lby = lbx+nek + lsx = lby+nek + lsy = lsx+m*km1 + call fpsurf(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest, + * eps,tol,maxit,nest,km1,km2,ib1,ib3,ncest,nrint,nreg,nx,tx, + * ny,ty,c,fp,wrk1(1),wrk1(lfp),wrk1(lco),wrk1(lf),wrk1(lff), + * wrk1(la),wrk1(lq),wrk1(lbx),wrk1(lby),wrk1(lsx),wrk1(lsy), + * wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier) + 70 return + 71 print*,"iopt,kx,ky,m=",iopt,kx,ky,m + print*,"nxest,nyest,nmax=",nxest,nyest,nmax + print*,"lwrk1,lwrk2,kwrk=",lwrk1,lwrk2,kwrk + print*,"xb,xe,yb,ye=",xb,xe,yb,ye + print*,"eps,s",eps,s + return + 72 print*,"tx=",tx + return + 73 print*,"ty=",ty + return + end diff --git a/main.cpp b/main.cpp index 540aaa0..6df60bf 100644 --- a/main.cpp +++ b/main.cpp @@ -1,8 +1,11 @@ -#include #include +#include + +#include +#include int main() { - std::cout << "AAA\n"; - return 0; + std::cout << "AAA\n"; + return 0; } diff --git a/mcc_angle.h b/mcc_angle.h new file mode 100644 index 0000000..87f898c --- /dev/null +++ b/mcc_angle.h @@ -0,0 +1,718 @@ +#pragma once + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * IMPLEMENTATION OF GEOMETRICAL ANGLE * + * * + ****************************************************************************************/ + + +#include + +#include "mcc_constants.h" +#include "mcc_traits.h" +#include "mcc_utils.h" + + +/* HELPERS TO REPRESENT ANGLE VALUE */ + +constexpr double operator""_rads(long double val) // angle in radians (no conversion) +{ + return val; +} + +constexpr double operator""_degs(long double val) // angle in degrees +{ + return val * std::numbers::pi / 180.0; +} + +constexpr double operator""_arcmins(long double val) // angle in arc minutes +{ + return val * std::numbers::pi / 180.0 / 60.0; +} + +constexpr double operator""_arcsecs(long double val) // angle in arc seconds +{ + return val * std::numbers::pi / 180.0 / 3600.0; +} + +constexpr double operator""_hours(long double val) // angle in hours +{ + return val * std::numbers::pi / 12.0; +} + +constexpr double operator""_mins(long double val) // angle in hour minutes +{ + return val * std::numbers::pi / 12.0 / 60.0; +} + +constexpr double operator""_secs(long double val) // angle in hour seconds +{ + return val * std::numbers::pi / 12.0 / 3600.0; +} + +constexpr double operator""_dms(const char* s, size_t size) // as a string "DEGREES:MINUTES:SECONDS" +{ + auto res = mcc::utils::parsAngleString(std::span{s, size}); + if (res.has_value()) { + return res.value() * std::numbers::pi / 180.0; + } else { + throw std::invalid_argument("invalid sexagesimal representation"); + } +} + +constexpr double operator""_hms(const char* s, size_t len) // as a string "HOURS:MINUTES:SECONDS" +{ + auto res = mcc::utils::parsAngleString(std::span{s, len}, true); + if (res.has_value()) { + return res.value() * std::numbers::pi / 180.0; + } else { + throw std::invalid_argument("invalid sexagesimal representation"); + } +} + + + +namespace mcc::impl +{ + +// tags for MccAngle class construction + +struct MccRadianTag { +}; +struct MccDegreeTag { +}; +static constexpr MccDegreeTag mcc_degrees{}; +struct MccHMSTag { +}; +static constexpr MccHMSTag mcc_hms{}; + + +class MccAngle +{ +protected: + double _angleInRads{0.0}; + int _precision{2}; + +public: + enum norm_kind_t { + NORM_KIND_0_360, // [0,360] + NORM_KIND_0_180, // [0,180] + NORM_KIND_180_180, // [-180,180] + NORM_KIND_90_90, // [-90,90] + }; + + MccAngle() = default; + + // by default 'val' is in radians + constexpr MccAngle(const double& val, const MccRadianTag = MccRadianTag{}) : _angleInRads(val) {} + + // construct angle from 'val' in degrees, e.g.: + // auto ang = MccAngle{180.0, mcc_degrees}; + constexpr MccAngle(const double& val, const MccDegreeTag) : _angleInRads(val * utils::deg2radCoeff) {} + + + + // constuct angle from sexagesimal representation or floating-point number of degrees, e.g.: + // auto ang = MccAngle{"-12:34:56.789"}; // from degrees:minutes:seconds + // auto ang = MccAngle{"123.574698"}; // from degrees + constexpr MccAngle(traits::mcc_input_char_range auto const& val) + { + auto res = utils::parsAngleString(val); + if (res.has_value()) { + _angleInRads = res.value() * utils::deg2radCoeff; + } else { + throw std::invalid_argument("invalid sexagesimal representation"); + } + } + + // construct angle from sexagesimal representation or floating-point number of degrees, e.g.: + // auto ang = MccAngle{"01:23:45.6789", mcc_hms}; // from hours:minutes:seconds + // auto ang = MccAngle{"123.574698"}; // from degrees + constexpr MccAngle(traits::mcc_input_char_range auto const& val, const MccHMSTag) + { + auto res = utils::parsAngleString(val, true); + if (res.has_value()) { + _angleInRads = res.value() * utils::deg2radCoeff; + } else { + throw std::invalid_argument("invalid sexagesimal representation"); + } + } + + MccAngle(const MccAngle&) = default; + MccAngle(MccAngle&&) = default; + + MccAngle& operator=(const MccAngle&) = default; + MccAngle& operator=(MccAngle&&) = default; + + virtual ~MccAngle() = default; + + template T> + constexpr auto& operator=(this T&& self, const T& other) + { + std::forward(self)._angleInRads = other._angleInRads; + + return self; + } + + template T> + constexpr auto& operator=(this T&& self, T&& other) + { + // std::forward(self)._angleInRads = std::move(other._angleInRads); + std::forward(self)._angleInRads = std::forward(other)._angleInRads; + + return self; + } + + template + constexpr auto& operator=(this auto&& self, const T& val) + requires std::is_arithmetic_v + { + std::forward(self)._angleInRads = val; + + return self; + } + + // normalize coordinate + template + MccAngle& normalize() + { + _angleInRads = std::fmod(_angleInRads, std::numbers::pi * 2.0); + + if constexpr (KIND == NORM_KIND_0_360) { + if (_angleInRads < 0.0) { + _angleInRads += 2.0 * std::numbers::pi; + } + } else if constexpr (KIND == NORM_KIND_0_180) { + if (_angleInRads < -std::numbers::pi) { + // _angleInRads = 2.0 * std::numbers::pi + _angleInRads; + _angleInRads = MCC_TWO_PI + _angleInRads; + } else if (_angleInRads < 0.0) { + _angleInRads = -_angleInRads; + } + } else if constexpr (KIND == NORM_KIND_180_180) { + if (_angleInRads > std::numbers::pi) { + // _angleInRads = 2.0 * std::numbers::pi - _angleInRads; + _angleInRads = MCC_TWO_PI - _angleInRads; + } else if (_angleInRads < -std::numbers::pi) { + // _angleInRads += 2.0 * std::numbers::pi; + _angleInRads += MCC_TWO_PI; + } + } else if constexpr (KIND == NORM_KIND_90_90) { + if (_angleInRads >= 1.5 * std::numbers::pi) { + _angleInRads = _angleInRads - 2.0 * std::numbers::pi; + } else if (_angleInRads >= std::numbers::pi / 2.0) { + _angleInRads = std::numbers::pi - _angleInRads; + } else if (_angleInRads <= -1.5 * std::numbers::pi) { + // _angleInRads += 2.0 * std::numbers::pi; + _angleInRads += MCC_TWO_PI; + } else if (_angleInRads <= -std::numbers::pi / 2.0) { + _angleInRads = -(std::numbers::pi + _angleInRads); + } + } + + return *this; + } + + MccAngle& normalize() + { + return normalize(); + } + + + // template + // operator T() const + // requires std::is_arithmetic_v + // { + // return _angleInRads; + // } + + constexpr operator double() const + { + return _angleInRads; + } + + + template + constexpr T degrees() const + { + return _angleInRads * 180.0 / std::numbers::pi; + } + + constexpr double degrees() const + { + return degrees(); + } + + + template + T arcmins() const + { + return _angleInRads * 10800.0 / std::numbers::pi; + } + + double arcmins() const + { + return arcmins(); + } + + + template + T arcsecs() const + { + return _angleInRads * 648000.0 / std::numbers::pi; + } + + double arcsecs() const + { + return arcsecs(); + } + + template + T hours() const + { + return _angleInRads * 12.0 / std::numbers::pi; + } + + double hours() const + { + return hours(); + } + + template + T minutes() const + { + return _angleInRads * 720.0 / std::numbers::pi; + } + + double minutes() const + { + return minutes(); + } + + template + T seconds() const + { + return _angleInRads * 43200.0 / std::numbers::pi; + } + + double seconds() const + { + return seconds(); + } + + + template + T sexagesimal(bool hms = false, int prec = 2) const + { + return utils::rad2sxg(_angleInRads, hms, prec >= 0 ? prec : _precision); + } + + std::string sexagesimal(bool hms = false, int prec = 2) const + { + return sexagesimal(hms, prec); + } + + + // arithmetics + + template T> + SelfT& operator+=(this SelfT& self, const T& v) + { + if constexpr (std::derived_from) { + static_assert(std::derived_from, "INCOMPATIBLE TYPES!"); + + self._angleInRads += v._angleInRads; + } else if constexpr (std::is_arithmetic_v) { + self._angleInRads += v; + } else { + self._angleInRads += MccAngle(v)._angleInRads; + } + + return self; + } + + template T> + SelfT& operator-=(this SelfT& self, const T& v) + { + if constexpr (std::derived_from) { + static_assert(std::derived_from, "INCOMPATIBLE TYPES!"); + + self._angleInRads -= v._angleInRads; + } else if constexpr (std::is_arithmetic_v) { + self._angleInRads -= v; + } else { + self._angleInRads -= MccAngle(v)._angleInRads; + } + + return self; + } + + template + SelfT& operator*=(this SelfT& self, const T& v) + requires std::is_arithmetic_v + { + self._angleInRads *= v; + + return self; + } + + template + SelfT& operator/=(this SelfT& self, const T& v) + requires std::is_arithmetic_v + { + self._angleInRads /= v; + + return self; + } + + + // unary '-' and '+' + template + SelfT operator-(this SelfT& self) + { + SelfT res = -self._angleInRads; + + return res; + } + + template + SelfT operator+(this SelfT& self) + { + return self; + } +}; + + +// binary arithmetic operations + +template T1, std::convertible_to T2> +static auto operator+(const T1& v1, const T2& v2) +{ + static_assert(std::convertible_to || std::convertible_to, "INCOMPATIBLE TYPES!"); + + using res_t = std::conditional_t && std::derived_from, T1, T2>; + + return res_t{(double)v1 + (double)v2}; +} + +template T1, std::convertible_to T2> +static auto operator-(const T1& v1, const T2& v2) +{ + static_assert(std::convertible_to || std::convertible_to, "INCOMPATIBLE TYPES!"); + + using res_t = std::conditional_t && std::derived_from, T1, T2>; + + return res_t{(double)v1 - (double)v2}; +} + + +template T1, std::convertible_to T2> +static auto operator*(const T1& v1, const T2& v2) +{ + if constexpr (std::is_arithmetic_v) { + return T2{(double)v2 * v1}; + } else if constexpr (std::is_arithmetic_v) { + return T1{(double)v1 * v2}; + } else { + using res_t = std::conditional_t && std::derived_from, T1, T2>; + return res_t{(double)v1 * (double)v2}; + // static_assert(false, "INCOMPATIBLE TYPES!"); + } +} + +template T1, typename T2> +static T1 operator/(const T1& v1, const T2& v2) + requires std::is_arithmetic_v +{ + return (double)v1 / v2; +} + + + +std::string MccAngleFancyString(std::convertible_to auto const& ang, + std::format_string val_fmt = "{}") +{ + std::string s; + + double abs_ang; + if constexpr (std::is_arithmetic_v>) { + abs_ang = std::abs(ang); + } else { + abs_ang = std::abs(MccAngle{ang}); + } + + if (abs_ang < 1.0_arcmins) { + std::format_to(std::back_inserter(s), val_fmt, MccAngle{ang}.arcsecs()); + s += " arcsecs"; + } else if (abs_ang < 1.0_degs) { + std::format_to(std::back_inserter(s), val_fmt, MccAngle{ang}.arcmins()); + s += " arcmins"; + } else { + std::format_to(std::back_inserter(s), val_fmt, MccAngle{ang}.degrees()); + s += " degs"; + } + + return s; +} + + +/* HELPER TYPES TO REPERESENT ANGLES ON THE CELESTIAL SPHERE */ + +class MccNamedAngle : public MccAngle +{ +public: + using MccAngle::MccAngle; + + constexpr MccNamedAngle(MccAngle&& other) + { + _angleInRads = (double)std::forward(other); + } + + constexpr MccNamedAngle& operator=(MccAngle&& other) + { + _angleInRads = (double)std::forward(other); + + return *this; + } +}; + +class MccAngleRA_ICRS : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleDEC_ICRS : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleRA_APP : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleDEC_APP : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleRA_OBS : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleDEC_OBS : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleHA : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleHA_APP : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleHA_OBS : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleAZ : public MccNamedAngle +// class MccAngleAZ : public MccAngle +{ +public: + using MccNamedAngle::MccNamedAngle; + // using MccAngle::MccAngle; +}; + +class MccAngleZD : public MccNamedAngle +// class MccAngleZD : public MccAngle +{ +public: + using MccNamedAngle::MccNamedAngle; + // using MccAngle::MccAngle; +}; + +static const MccAngleAZ az{MccAngle{}}; + +class MccAngleALT : public MccNamedAngle +// class MccAngleALT : public MccAngle +{ +public: + using MccNamedAngle::MccNamedAngle; + // using MccAngle::MccAngle; +}; + + +class MccAngleX : public MccAngle // some co-longitude coordinate +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleY : public MccAngle // some co-latitude coordinate +{ +public: + using MccAngle::MccAngle; +}; + + + +class MccAngleLAT : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleLON : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + +class MccAngleUnknown : public MccAngle +{ +public: + using MccAngle::MccAngle; +}; + + +enum class MccCoordKind : size_t { + COORDS_KIND_GENERIC = traits::mcc_type_hash, + COORDS_KIND_RA_ICRS = traits::mcc_type_hash, + COORDS_KIND_DEC_ICRS = traits::mcc_type_hash, + COORDS_KIND_RA_APP = traits::mcc_type_hash, + COORDS_KIND_DEC_APP = traits::mcc_type_hash, + COORDS_KIND_RA_OBS = traits::mcc_type_hash, + COORDS_KIND_DEC_OBS = traits::mcc_type_hash, + COORDS_KIND_HA_APP = traits::mcc_type_hash, + COORDS_KIND_HA_OBS = traits::mcc_type_hash, + COORDS_KIND_AZ = traits::mcc_type_hash, + COORDS_KIND_ZD = traits::mcc_type_hash, + COORDS_KIND_ALT = traits::mcc_type_hash, + COORDS_KIND_X = traits::mcc_type_hash, + COORDS_KIND_Y = traits::mcc_type_hash, + COORDS_KIND_LAT = traits::mcc_type_hash, + COORDS_KIND_LON = traits::mcc_type_hash, + COORDS_KIND_UKNOWN = traits::mcc_type_hash +}; + +enum class MccCoordPairKind : size_t { + COORDS_KIND_GENERIC = traits::mcc_type_pair_hash(), + COORDS_KIND_RADEC_ICRS = traits::mcc_type_pair_hash(), + COORDS_KIND_RADEC_APP = traits::mcc_type_pair_hash(), + COORDS_KIND_RADEC_OBS = traits::mcc_type_pair_hash(), + COORDS_KIND_HADEC_APP = traits::mcc_type_pair_hash(), + COORDS_KIND_HADEC_OBS = traits::mcc_type_pair_hash(), + COORDS_KIND_AZZD = traits::mcc_type_pair_hash(), + COORDS_KIND_AZALT = traits::mcc_type_pair_hash(), + COORDS_KIND_XY = traits::mcc_type_pair_hash(), + COORDS_KIND_LONLAT = traits::mcc_type_pair_hash(), + COORDS_KIND_UNKNOWN = traits::mcc_type_pair_hash() +}; + +template +static constexpr bool mccIsObsCoordPairKind = + (PK == MccCoordPairKind::COORDS_KIND_RADEC_OBS || PK == MccCoordPairKind::COORDS_KIND_HADEC_OBS || + PK == MccCoordPairKind::COORDS_KIND_AZZD || PK == MccCoordPairKind::COORDS_KIND_AZALT); + +static constexpr bool mcc_is_obs_coordpair(MccCoordPairKind kind) +{ + return kind == MccCoordPairKind::COORDS_KIND_RADEC_OBS || kind == MccCoordPairKind::COORDS_KIND_HADEC_OBS || + kind == MccCoordPairKind::COORDS_KIND_AZZD || kind == MccCoordPairKind::COORDS_KIND_AZALT; +}; + +template +static constexpr bool mccIsAppCoordPairKind = + (PK == MccCoordPairKind::COORDS_KIND_RADEC_APP || PK == MccCoordPairKind::COORDS_KIND_HADEC_APP); + +static constexpr bool mcc_is_app_coordpair(MccCoordPairKind kind) +{ + return kind == MccCoordPairKind::COORDS_KIND_RADEC_APP || kind == MccCoordPairKind::COORDS_KIND_HADEC_APP; +}; + + +static constexpr std::string_view MCC_COORDPAIR_KIND_RADEC_ICRS_STR = "RADEC-IRCS"; +static constexpr std::string_view MCC_COORDPAIR_KIND_RADEC_APP_STR = "RADEC-APP"; +static constexpr std::string_view MCC_COORDPAIR_KIND_RADEC_OBS_STR = "RADEC-OBS"; +static constexpr std::string_view MCC_COORDPAIR_KIND_HADEC_APP_STR = "HADEC-APP"; +static constexpr std::string_view MCC_COORDPAIR_KIND_HADEC_OBS_STR = "HADEC-OBS"; +static constexpr std::string_view MCC_COORDPAIR_KIND_AZALT_STR = "AZALT"; +static constexpr std::string_view MCC_COORDPAIR_KIND_AZZD_STR = "AZZD"; +static constexpr std::string_view MCC_COORDPAIR_KIND_XY_STR = "XY"; +static constexpr std::string_view MCC_COORDPAIR_KIND_LATLON_STR = "LATLON"; +static constexpr std::string_view MCC_COORDPAIR_KIND_GENERIC_STR = "GENERIC"; +static constexpr std::string_view MCC_COORDPAIR_KIND_UNKNOWN_STR = "UNKNOWN"; + +template +static constexpr std::string_view MccCoordPairKindStr = + KIND == MccCoordPairKind::COORDS_KIND_RADEC_ICRS ? MCC_COORDPAIR_KIND_RADEC_ICRS_STR + : KIND == MccCoordPairKind::COORDS_KIND_RADEC_APP ? MCC_COORDPAIR_KIND_RADEC_APP_STR + : KIND == MccCoordPairKind::COORDS_KIND_RADEC_OBS ? MCC_COORDPAIR_KIND_RADEC_OBS_STR + : KIND == MccCoordPairKind::COORDS_KIND_HADEC_APP ? MCC_COORDPAIR_KIND_HADEC_APP_STR + : KIND == MccCoordPairKind::COORDS_KIND_HADEC_OBS ? MCC_COORDPAIR_KIND_HADEC_OBS_STR + : KIND == MccCoordPairKind::COORDS_KIND_AZALT ? MCC_COORDPAIR_KIND_AZALT_STR + : KIND == MccCoordPairKind::COORDS_KIND_AZZD ? MCC_COORDPAIR_KIND_AZZD_STR + : KIND == MccCoordPairKind::COORDS_KIND_XY ? MCC_COORDPAIR_KIND_XY_STR + : KIND == MccCoordPairKind::COORDS_KIND_LONLAT ? MCC_COORDPAIR_KIND_LATLON_STR + : KIND == MccCoordPairKind::COORDS_KIND_GENERIC ? MCC_COORDPAIR_KIND_GENERIC_STR + : MCC_COORDPAIR_KIND_UNKNOWN_STR; + + +static constexpr std::string_view MccCoordPairKindToStr(MccCoordPairKind KIND) +{ + return KIND == MccCoordPairKind::COORDS_KIND_RADEC_ICRS ? MCC_COORDPAIR_KIND_RADEC_ICRS_STR + : KIND == MccCoordPairKind::COORDS_KIND_RADEC_APP ? MCC_COORDPAIR_KIND_RADEC_APP_STR + : KIND == MccCoordPairKind::COORDS_KIND_RADEC_OBS ? MCC_COORDPAIR_KIND_RADEC_OBS_STR + : KIND == MccCoordPairKind::COORDS_KIND_HADEC_APP ? MCC_COORDPAIR_KIND_HADEC_APP_STR + : KIND == MccCoordPairKind::COORDS_KIND_HADEC_OBS ? MCC_COORDPAIR_KIND_HADEC_OBS_STR + : KIND == MccCoordPairKind::COORDS_KIND_AZALT ? MCC_COORDPAIR_KIND_AZALT_STR + : KIND == MccCoordPairKind::COORDS_KIND_AZZD ? MCC_COORDPAIR_KIND_AZZD_STR + : KIND == MccCoordPairKind::COORDS_KIND_XY ? MCC_COORDPAIR_KIND_XY_STR + : KIND == MccCoordPairKind::COORDS_KIND_LONLAT ? MCC_COORDPAIR_KIND_LATLON_STR + : KIND == MccCoordPairKind::COORDS_KIND_GENERIC ? MCC_COORDPAIR_KIND_GENERIC_STR + : MCC_COORDPAIR_KIND_UNKNOWN_STR; +} + + +template +static constexpr MccCoordPairKind MccCoordStrToPairKind(R&& spair) +{ + if constexpr (std::is_pointer_v>) { + return MccCoordStrToPairKind(std::string_view{spair}); + } + + const auto hash = mcc::utils::FNV1aHash(std::forward(spair)); + + return hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_RADEC_ICRS_STR) ? MccCoordPairKind::COORDS_KIND_RADEC_ICRS + : hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_RADEC_APP_STR) ? MccCoordPairKind::COORDS_KIND_RADEC_APP + : hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_RADEC_OBS_STR) ? MccCoordPairKind::COORDS_KIND_RADEC_OBS + : hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_HADEC_APP_STR) ? MccCoordPairKind::COORDS_KIND_HADEC_APP + : hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_HADEC_OBS_STR) ? MccCoordPairKind::COORDS_KIND_HADEC_OBS + : hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_AZALT_STR) ? MccCoordPairKind::COORDS_KIND_AZALT + : hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_AZZD_STR) ? MccCoordPairKind::COORDS_KIND_AZZD + : hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_XY_STR) ? MccCoordPairKind::COORDS_KIND_XY + : hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_LATLON_STR) ? MccCoordPairKind::COORDS_KIND_LONLAT + : hash == mcc::utils::FNV1aHash(MCC_COORDPAIR_KIND_GENERIC_STR) ? MccCoordPairKind::COORDS_KIND_GENERIC + : MccCoordPairKind::COORDS_KIND_UNKNOWN; +} + + +} // namespace mcc::impl diff --git a/mcc_ccte_erfa.h b/mcc_ccte_erfa.h new file mode 100644 index 0000000..4d89d95 --- /dev/null +++ b/mcc_ccte_erfa.h @@ -0,0 +1,895 @@ +#pragma once + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * IMPLEMENTATION OF CELESTIAL COORDINATES TRANSFORMATION ENGINE * + * (BASING ON THE ERFA LIBRARY) * + * * + ****************************************************************************************/ + + + +#include +#include +#include + + +#include +#include + +// #include "build/Desktop-Debug/erfa_lib/erfa.h" +// #include "build/Desktop-Debug/erfa_lib/erfam.h" + +#include "mcc_ccte_iers.h" +#include "mcc_concepts.h" +#include "mcc_error.h" + +namespace mcc::ccte::erfa +{ + + +enum class MccCCTE_ERFAErrorCode : int { + ERROR_OK = 0, + ERROR_NULLPTR, + ERROR_INVALID_INPUT_ARG, + ERROR_julday_INVALID_YEAR, + ERROR_julday_INVALID_MONTH, + ERROR_julday_INVALID_DAY, + ERROR_UNSUPPORTED_COORD_PAIR, + ERROR_BULLETINA_OUT_OF_RANGE, + ERROR_LEAPSECONDS_OUT_OF_RANGE, + ERROR_DUBIOUS_YEAR, + ERROR_UNACCEPTABLE_DATE, + ERROR_UPDATE_LEAPSECONDS, + ERROR_UPDATE_BULLETINA, + ERROR_UNEXPECTED +}; + +} // namespace mcc::ccte::erfa + + +namespace std +{ + +template <> +class is_error_code_enum : public true_type +{ +}; + +} // namespace std + + + +namespace mcc::ccte::erfa +{ + +/* error category definition */ + +// error category +struct MccCCTE_ERFACategory : public std::error_category { + MccCCTE_ERFACategory() : std::error_category() {} + + const char* name() const noexcept + { + return "CCTE-ERFA"; + } + + std::string message(int ec) const + { + MccCCTE_ERFAErrorCode err = static_cast(ec); + + switch (err) { + case MccCCTE_ERFAErrorCode::ERROR_OK: + return "OK"; + case MccCCTE_ERFAErrorCode::ERROR_NULLPTR: + return "input argument is the nullptr"; + case MccCCTE_ERFAErrorCode::ERROR_INVALID_INPUT_ARG: + return "invalid argument"; + case MccCCTE_ERFAErrorCode::ERROR_julday_INVALID_YEAR: + return "invalid year number"; + case MccCCTE_ERFAErrorCode::ERROR_julday_INVALID_MONTH: + return "invalid month number"; + case MccCCTE_ERFAErrorCode::ERROR_julday_INVALID_DAY: + return "invalid day number"; + case MccCCTE_ERFAErrorCode::ERROR_UNSUPPORTED_COORD_PAIR: + return "unsupported coordinate pair"; + case MccCCTE_ERFAErrorCode::ERROR_BULLETINA_OUT_OF_RANGE: + return "time point is out of range"; + case MccCCTE_ERFAErrorCode::ERROR_LEAPSECONDS_OUT_OF_RANGE: + return "time point is out of range"; + case MccCCTE_ERFAErrorCode::ERROR_DUBIOUS_YEAR: + return "dubious year"; + case MccCCTE_ERFAErrorCode::ERROR_UNACCEPTABLE_DATE: + return "unacceptable date"; + case MccCCTE_ERFAErrorCode::ERROR_UPDATE_LEAPSECONDS: + return "leap seconds update error"; + case MccCCTE_ERFAErrorCode::ERROR_UPDATE_BULLETINA: + return "bulletin A update error"; + case MccCCTE_ERFAErrorCode::ERROR_UNEXPECTED: + return "unexpected error value"; + default: + return "UNKNOWN"; + } + } + + static const MccCCTE_ERFACategory& get() + { + static const MccCCTE_ERFACategory constInst; + return constInst; + } +}; + + +inline mcc::impl::MccError make_error_code(MccCCTE_ERFAErrorCode ec) +{ + static_assert(std::same_as, + "MccError type must be an alias of std::error_code"); + + return mcc::impl::MccError(static_cast(ec), MccCCTE_ERFACategory::get()); +} + + +class MccCCTE_ERFA : public mcc_ccte_engine_interface_t +{ + static constexpr double PI_2 = std::numbers::pi / 2.0; + +public: + static constexpr double DEFAULT_WAVELENGTH = 0.55; // default observed wavelength in mkm + + typedef mcc::impl::MccError error_t; + + static constexpr std::string_view ccteName = "ERFA-CCTE-ENGINE"; + + struct refract_model_t { + static constexpr std::string_view name() + { + return "ERFA"; + } + + double refa, refb; + }; + + + // meteo parameters (to compute refraction) + struct meteo_t { + typedef double temp_t; + typedef double humid_t; + typedef double press_t; + + temp_t temperature; // Temperature in C + humid_t humidity; // humidity in % ([0.0, 1.0]) + press_t pressure; // atmospheric presure in hPa=mB + }; + + // celestial object addition parameters + struct obj_pars_t { + double pm_RA = 0.0; // rads/year + double pm_DEC = 0.0; // rads/year + double parallax; // in arcsecs + double radvel; // radial velocity (signed, km/s) + }; + + struct engine_state_t { + meteo_t meteo{.temperature = 0.0, .humidity = 0.5, .pressure = 1010.0}; + + double wavelength = DEFAULT_WAVELENGTH; // observed wavelength in mkm + + double lat = 0.0; // site latitude + double lon = 0.0; // site longitude + double elev = 0.0; // site elevation (in meters) + + mcc::ccte::iers::MccLeapSeconds _leapSeconds{}; + mcc::ccte::iers::MccIersBulletinA _bulletinA{}; + }; + + MccCCTE_ERFA() {} + + MccCCTE_ERFA(engine_state_t state) : MccCCTE_ERFA() + { + _currentState = std::move(state); + } + + MccCCTE_ERFA(const MccCCTE_ERFA&) = delete; + MccCCTE_ERFA& operator=(const MccCCTE_ERFA&) = delete; + + MccCCTE_ERFA(MccCCTE_ERFA&&) = default; + MccCCTE_ERFA& operator=(MccCCTE_ERFA&&) = default; + + virtual ~MccCCTE_ERFA() = default; + + + // engine state related methods + + void setStateERFA(engine_state_t state) + { + std::lock_guard lock{*_stateMutex}; + + _currentState = std::move(state); + } + + engine_state_t getStateERFA() const + { + std::lock_guard lock{*_stateMutex}; + + return _currentState; + } + + void updateMeteoERFA(meteo_t meteo) + { + std::lock_guard lock{*_stateMutex}; + + _currentState.meteo = std::move(meteo); + + // update refraction model coefficients + eraRefco(_currentState.meteo.pressure, _currentState.meteo.temperature, _currentState.meteo.humidity, + _currentState.wavelength, &_currentRefractModel.refa, &_currentRefractModel.refb); + } + + error_t updateLeapSeconds(std::derived_from> auto& stream, char comment_sym = '#') + { + std::lock_guard lock{*_stateMutex}; + + if (!_currentState._leapSeconds.load(stream, comment_sym)) { + return MccCCTE_ERFAErrorCode::ERROR_UPDATE_LEAPSECONDS; + } + + return MccCCTE_ERFAErrorCode::ERROR_OK; + } + + + error_t updateLeapSeconds(traits::mcc_input_char_range auto const& filename, char comment_sym = '#') + { + std::lock_guard lock{*_stateMutex}; + + if (!_currentState._leapSeconds.load(filename, comment_sym)) { + return MccCCTE_ERFAErrorCode::ERROR_UPDATE_LEAPSECONDS; + } + + return MccCCTE_ERFAErrorCode::ERROR_OK; + } + + + error_t updateBulletinA(std::derived_from> auto& stream, char comment_sym = '*') + { + std::lock_guard lock{*_stateMutex}; + + if (!_currentState._bulletinA.load(stream, comment_sym)) { + return MccCCTE_ERFAErrorCode::ERROR_UPDATE_BULLETINA; + } + + return MccCCTE_ERFAErrorCode::ERROR_OK; + } + + + error_t updateBulletinA(traits::mcc_input_char_range auto const& filename, char comment_sym = '*') + { + std::lock_guard lock{*_stateMutex}; + + if (!_currentState._bulletinA.load(filename, comment_sym)) { + return MccCCTE_ERFAErrorCode::ERROR_UPDATE_BULLETINA; + } + + return MccCCTE_ERFAErrorCode::ERROR_OK; + } + + + // latitude and longitude + template + void geoPosition(std::pair* coords) const + { + std::lock_guard lock{*_stateMutex}; + + if (coords) { + coords->first = _currentState.lat; + coords->second = _currentState.lon; + } + } + + + // apparent sideral time (Greenwitch or local) + error_t apparentSideralTime(mcc_coord_epoch_c auto const& epoch, mcc_angle_c auto* st, bool islocal = false) + { + error_t ret = MccCCTE_ERFAErrorCode::ERROR_OK; + + if (st == nullptr) { + return MccCCTE_ERFAErrorCode::ERROR_NULLPTR; + } + + using real_days_t = std::chrono::duration>; + + double ut1 = epoch.MJD(); + double tt = epoch.MJD(); + + std::lock_guard lock{*_stateMutex}; + + auto dut1 = _currentState._bulletinA.DUT1(epoch.MJD()); + + if (dut1.has_value()) { + ut1 += std::chrono::duration_cast(dut1.value()).count(); + } else { // out of range + return MccCCTE_ERFAErrorCode::ERROR_BULLETINA_OUT_OF_RANGE; + } + + auto tai_utc = _currentState._leapSeconds[epoch.MJD()]; + if (tai_utc.has_value()) { + tt += std::chrono::duration_cast(tai_utc.value()).count(); + } else { + return MccCCTE_ERFAErrorCode::ERROR_LEAPSECONDS_OUT_OF_RANGE; + } + + + auto tt_tai = _currentState._bulletinA.TT_TAI(); + tt += std::chrono::duration_cast(tt_tai).count(); + + *st = eraGst06a(ERFA_DJM0, ut1, ERFA_DJM0, tt); + + if (islocal) { + *st = eraAnp(*st + _currentState.lon); + } + + return ret; + } + + + // ICRS to observed + // returned azimuth is counted from the South through the West + error_t icrsToObs(mcc_angle_c auto const& ra_icrs, + mcc_angle_c auto const& dec_icrs, + mcc_coord_epoch_c auto const& epoch, + mcc_angle_c auto* ra_obs, + mcc_angle_c auto* dec_obs, + mcc_angle_c auto* ha_obs, + mcc_angle_c auto* az, + mcc_angle_c auto* zd, + obj_pars_t* obj_params = nullptr) + { + return icrsTo(true, ra_icrs, dec_icrs, epoch, ra_obs, dec_obs, ha_obs, az, zd, obj_params); + } + + // error_t icrsToObs(MccSkyRADEC_ICRS const& radec_icrs, + // MccSkyRADEC_OBS* radec_obs, + // MccSkyAZZD* azzd, + // mcc_angle_c auto* ha_obs, + // obj_pars_t* obj_params = nullptr) + // { + // double ra_obs, dec_obs, az, zd, ha; + + // auto err = + // icrsToObs(radec_icrs.x(), radec_icrs.y(), radec_icrs.epoch(), &ra_obs, &dec_obs, &ha, &az, &zd, + // obj_params); + + // if (!err) { + // if (radec_obs) { + // radec_obs->setX(ra_obs); + // radec_obs->setY(dec_obs); + // } + + // if (azzd) { + // azzd->setEpoch(radec_obs->epoch()); + // azzd->setX(az); + // azzd->setY(zd); + // } + + // if (ha_obs) { + // *ha_obs = ha; + // } + // } + + // return err; + // }; + + + // ICRS to apparent (in vacuo) + // returned azimuth is counted from the South through the West + error_t icrsToApp(mcc_angle_c auto const& ra_icrs, + mcc_angle_c auto const& dec_icrs, + mcc_coord_epoch_c auto const& epoch, + mcc_angle_c auto* ra_app, + mcc_angle_c auto* dec_app, + mcc_angle_c auto* ha_app, + mcc_angle_c auto* az, + mcc_angle_c auto* zd, // should be interpretated as zenithal distance corrected for refraction + obj_pars_t* obj_params = nullptr) + { + return icrsTo(false, ra_icrs, dec_icrs, epoch, ra_app, dec_app, ha_app, az, zd, obj_params); + } + + + // error_t icrsToApp(MccSkyRADEC_ICRS const& radec_icrs, + // MccSkyRADEC_OBS* radec_app, + // MccSkyAZZD* azzd, + // mcc_angle_c auto* ha_app, + // obj_pars_t* obj_params = nullptr) + // { + // double ra_app, dec_app, az, zd, ha; + + // auto err = + // icrsToApp(radec_icrs.x(), radec_icrs.y(), radec_icrs.epoch(), &ra_app, &dec_app, &ha, &az, &zd, + // obj_params); + + // if (!err) { + // if (radec_app) { + // radec_app->setX(ra_app); + // radec_app->setY(dec_app); + // } + + // if (azzd) { + // azzd->setEpoch(radec_app->epoch()); + // azzd->setX(az); + // azzd->setY(zd); + // } + + // if (ha_app) { + // *ha_app = ha; + // } + // } + + // return err; + // } + + + error_t obsToICRS(impl::MccCoordPairKind obs_type, + mcc_coord_epoch_c auto const& epoch, + mcc_angle_c auto const& co_lon, + mcc_angle_c auto const& co_lat, + mcc_angle_c auto* ra_icrs, + mcc_angle_c auto* dec_icrs) + { + return toICRS(true, obs_type, epoch, co_lon, co_lat, ra_icrs, dec_icrs); + } + + + // error_t obsToICRS(mcc_coord_pair_c auto const& xy_obs, MccSkyRADEC_ICRS* radec_icrs) + // { + // double ra, dec; + + // auto err = obsToICRS(xy_obs.pair_kind, xy_obs.epoch(), xy_obs.x(), xy_obs.y(), &ra, &dec); + // if (err) { + // return err; + // } + + // if (radec_icrs) { + // radec_icrs->setX(ra); + // radec_icrs->setY(dec); + // } + + // return err; + // } + + + error_t appToICRS(impl::MccCoordPairKind app_type, + mcc_coord_epoch_c auto const& epoch, + mcc_angle_c auto const& co_lon, + mcc_angle_c auto const& co_lat, + mcc_angle_c auto* ra_icrs, + mcc_angle_c auto* dec_icrs) + { + return toICRS(false, app_type, epoch, co_lon, co_lat, ra_icrs, dec_icrs); + } + + + // error_t appToICRS(mcc_coord_pair_c auto const& xy_app, MccSkyRADEC_ICRS* radec_icrs) + // { + // double ra, dec; + + // auto err = appToICRS(xy_app.pair_kind, xy_app.epoch(), xy_app.x(), xy_app.y(), &ra, &dec); + // if (!err) { + // if (radec_icrs) { + // radec_icrs->setX(ra); + // radec_icrs->setY(dec); + // } + // } + + // return err; + // } + + + error_t equationOrigins(mcc_coord_epoch_c auto const& epoch, mcc_angle_c auto* eo) + { + if (eo == nullptr) { + return MccCCTE_ERFAErrorCode::ERROR_NULLPTR; + } + + error_t ret = MccCCTE_ERFAErrorCode::ERROR_OK; + + std::lock_guard lock{*_stateMutex}; + + using real_days_t = std::chrono::duration>; + + double mjd = epoch.MJD(); + + auto tai_utc = _currentState._leapSeconds[mjd]; + if (tai_utc.has_value()) { + double tt = mjd; + tt += std::chrono::duration_cast(tai_utc.value()).count(); + + auto tt_tai = _currentState._bulletinA.TT_TAI(); + tt += +std::chrono::duration_cast(tt_tai).count(); + + *eo = eraEo06a(ERFA_DJM0, tt); + } else { + ret = MccCCTE_ERFAErrorCode::ERROR_LEAPSECONDS_OUT_OF_RANGE; + } + + return ret; + } + + // refraction + + error_t refractionModel(refract_model_t* model) + { + if (model == nullptr) { + return MccCCTE_ERFAErrorCode::ERROR_NULLPTR; + } + + std::lock_guard lock{*_stateMutex}; + + // eraRefco(_currentState.meteo.pressure, _currentState.meteo.temperature, _currentState.meteo.humidity, + // _currentState.wavelength, &model->refa, &model->refb); + + *model = _currentRefractModel; + + return MccCCTE_ERFAErrorCode::ERROR_OK; + } + + // Zobs must be observed zenithal distance (Zapp = Zobs + dZ -- corrected (in vacuo) zenithal distance) + template + error_t refractionCorrection(mcc_angle_c auto Zobs, mcc_angle_c auto* dZ, ZAPP_T Zapp = nullptr) + requires(std::is_null_pointer_v || + (std::is_pointer_v && mcc_angle_c>)) + { + error_t ret = MccCCTE_ERFAErrorCode::ERROR_OK; + + if (dZ == nullptr) { + return MccCCTE_ERFAErrorCode::ERROR_NULLPTR; + } + + // refract_model_t rmodel; + // ret = refractionModel(&rmodel); + + // if (!ret) { + // ret = refractionCorrection(rmodel, Zobs, dZ, Zapp); + // } + + { + std::lock_guard lock(*_stateMutex); + + ret = refractionCorrection(_currentRefractModel, Zobs, dZ, Zapp); + } + + return ret; + } + + // Zobs must be observed zenithal distance (Zapp = Zobs + dZ -- corrected (in vacuo) zenithal distance) + template + error_t refractionCorrection(const refract_model_t& rmodel, + mcc_angle_c auto Zobs, + mcc_angle_c auto* dZ, + ZAPP_T Zapp = nullptr) + requires(std::is_null_pointer_v || + (std::is_pointer_v && mcc_angle_c>)) + { + error_t ret = MccCCTE_ERFAErrorCode::ERROR_OK; + + if (dZ == nullptr) { + return MccCCTE_ERFAErrorCode::ERROR_NULLPTR; + } + + + if (Zobs >= std::numbers::pi / 2.0) { + *dZ = 35.4 / 60.0 * std::numbers::pi / 180.0; // 35.4 arcminutes + } else { + auto tanZ = tan(Zobs); + *dZ = rmodel.refa * tanZ + rmodel.refb * tanZ * tanZ * tanZ; + } + + if constexpr (!std::is_null_pointer_v) { + *Zapp = Zobs + *dZ; + } + + return ret; + } + + + // Zapp must be topocentric (in vacuo) zenithal distance (Zobs = Zapp - dZ -- observed, i.e. affected by refraction, + // zenithal distance) + template + error_t refractionInverseCorrection(mcc_angle_c auto Zapp, mcc_angle_c auto* dZ, ZOBS_T Zobs = nullptr) + requires(std::is_null_pointer_v || + (std::is_pointer_v && mcc_angle_c>)) + { + error_t ret = MccCCTE_ERFAErrorCode::ERROR_OK; + + if (dZ == nullptr) { + return MccCCTE_ERFAErrorCode::ERROR_NULLPTR; + } + + // refract_model_t rmodel; + // ret = refractionModel(&rmodel); + + // if (!ret) { + // ret = refractionInverseCorrection(rmodel, Zapp, dZ, Zobs); + // } + + { + std::lock_guard lock(*_stateMutex); + + ret = refractionInverseCorrection(_currentRefractModel, Zapp, dZ, Zobs); + } + + return ret; + } + + + // Zapp must be topocentric (in vacuo) zenithal distance (Zobs = Zapp - dZ -- observed, i.e. affected by refraction, + // zenithal distance) + template + error_t refractionInverseCorrection(const refract_model_t& rmodel, + mcc_angle_c auto Zapp, + mcc_angle_c auto* dZ, + ZOBS_T Zobs = nullptr) + requires(std::is_null_pointer_v || + (std::is_pointer_v && mcc_angle_c>)) + { + error_t ret = MccCCTE_ERFAErrorCode::ERROR_OK; + + if (dZ == nullptr) { + return MccCCTE_ERFAErrorCode::ERROR_NULLPTR; + } + + + if (Zapp >= std::numbers::pi / 2.0) { + *dZ = 35.4 / 60.0 * std::numbers::pi / 180.0; // 35.4 arcminutes + } else { + auto tanZ = tan(Zapp); + auto tanZ2 = tanZ * tanZ; + auto b3 = 3.0 * rmodel.refb; + + // with Newton-Raphson correction + *dZ = (rmodel.refa * tanZ + rmodel.refb * tanZ * tanZ2) / + (1.0 + rmodel.refa + tanZ2 * (rmodel.refa + b3) + b3 * tanZ2 * tanZ2); + } + + if constexpr (!std::is_null_pointer_v) { + *Zobs = Zapp - *dZ; + } + + return ret; + } + + + /* helper mathods */ + + auto leapSecondsExpireDate() const + { + return _currentState._leapSeconds.expireDate(); + } + + auto leapSecondsExpireMJD() const + { + return _currentState._leapSeconds.expireMJD(); + } + + + auto bulletinADateRange() const + { + return _currentState._bulletinA.dateRange(); + } + + auto bulletinADateRangeMJD() const + { + return _currentState._bulletinA.dateRangeMJD(); + } + + +protected: + engine_state_t _currentState{}; + + refract_model_t _currentRefractModel{}; + + std::unique_ptr _stateMutex{new std::mutex()}; + + + error_t icrsTo(bool observed, // true - observed, false - apparent + mcc_angle_c auto const& ra_icrs, + mcc_angle_c auto const& dec_icrs, + mcc_coord_epoch_c auto const& epoch, + mcc_angle_c auto* ra, + mcc_angle_c auto* dec, + mcc_angle_c auto* ha, + mcc_angle_c auto* az, + mcc_angle_c auto* zd, + obj_pars_t* obj_params = nullptr) + { + int err; + double r, d, h, a, z, eo; + double pressure = 0.0; // 0 for apparent coordinates type (see ERFA's refco.c: if pressure is zero then + // refraction is also zero) + + + error_t ret = MccCCTE_ERFAErrorCode::ERROR_OK; + + std::lock_guard lock{*_stateMutex}; + + if (observed) { + pressure = _currentState.meteo.pressure; + } + + auto dut1 = _currentState._bulletinA.DUT1(epoch.MJD()); + + if (!dut1.has_value()) { + return MccCCTE_ERFAErrorCode::ERROR_BULLETINA_OUT_OF_RANGE; + } + + auto pol_pos = _currentState._bulletinA.polarCoords(epoch.MJD()); + if (!pol_pos.has_value()) { + return MccCCTE_ERFAErrorCode::ERROR_BULLETINA_OUT_OF_RANGE; + } + + // const auto arcsec2rad = std::numbers::pi / 180 / 3600; + const auto arcsec2rad = 1.0_arcsecs; + pol_pos->x *= arcsec2rad; + pol_pos->y *= arcsec2rad; + + if (obj_params) { + err = eraAtco13(ra_icrs, dec_icrs, obj_params->pm_RA, obj_params->pm_DEC, obj_params->parallax, + obj_params->radvel, ERFA_DJM0, epoch.MJD(), dut1->count(), _currentState.lon, + _currentState.lat, _currentState.elev, pol_pos->x, pol_pos->y, pressure, + _currentState.meteo.temperature, _currentState.meteo.humidity, _currentState.wavelength, &a, + &z, &h, &d, &r, &eo); + } else { + err = eraAtco13(ra_icrs, dec_icrs, 0.0, 0.0, 0.0, 0.0, ERFA_DJM0, epoch.MJD(), dut1->count(), + _currentState.lon, _currentState.lat, _currentState.elev, pol_pos->x, pol_pos->y, pressure, + _currentState.meteo.temperature, _currentState.meteo.humidity, _currentState.wavelength, &a, + &z, &h, &d, &r, &eo); + } + + if (err == 1) { + ret = MccCCTE_ERFAErrorCode::ERROR_DUBIOUS_YEAR; + } else if (err == -1) { + ret = MccCCTE_ERFAErrorCode::ERROR_UNACCEPTABLE_DATE; + } + + + if (ra) { + *ra = r; + } + + if (dec) { + *dec = d; + } + + if (ha) { + *ha = h; + } + + if (az) { + // NOTE: according to definition of astronomical azimuth it is counted from the South through the West, but + // in the ERFA the azimuth is counted from the North through the East!!! + // + *az = impl::MccAngle(a - std::numbers::pi).normalize(); + // *az = MccAngle(a + std::numbers::pi).normalize(); + } + + if (zd) { + *zd = z; + } + + return ret; + } + + error_t toICRS(bool observed, // true - observed, false - apparent + impl::MccCoordPairKind pair_type, + mcc_coord_epoch_c auto const& epoch, + mcc_angle_c auto const& co_lon, + mcc_angle_c auto const& co_lat, + mcc_angle_c auto* ra_icrs, + mcc_angle_c auto* dec_icrs) + { + error_t ret = MccCCTE_ERFAErrorCode::ERROR_OK; + + // check coordinate pair consistency + if (mcc_is_app_coordpair(pair_type) && observed) { + return MccCCTE_ERFAErrorCode::ERROR_UNSUPPORTED_COORD_PAIR; + } + if (mcc_is_obs_coordpair(pair_type) && !observed) { + return MccCCTE_ERFAErrorCode::ERROR_UNSUPPORTED_COORD_PAIR; + } + + std::lock_guard lock{*_stateMutex}; + + auto dut1 = _currentState._bulletinA.DUT1(epoch.MJD()); + + if (!dut1.has_value()) { + return MccCCTE_ERFAErrorCode::ERROR_BULLETINA_OUT_OF_RANGE; + } + + auto pol_pos = _currentState._bulletinA.polarCoords(epoch.MJD()); + if (!pol_pos.has_value()) { + return MccCCTE_ERFAErrorCode::ERROR_BULLETINA_OUT_OF_RANGE; + } + + // const auto arcsec2rad = std::numbers::pi / 180 / 3600; + const auto arcsec2rad = 1.0_arcsecs; + pol_pos->x *= arcsec2rad; + pol_pos->y *= arcsec2rad; + + std::string type; + double x, y, ra, dec; + double pressure = 0.0; + + if (observed) { + pressure = _currentState.meteo.pressure; + } + + switch (pair_type) { + case impl::MccCoordPairKind::COORDS_KIND_AZZD: + // NOTE: according to definition of astronomical azimuth it is counted from the South through the West, + // but in the ERFA the azimuth is counted from the North through the East!!! + // + x = co_lon + std::numbers::pi; + y = co_lat; + type = "A"; + break; + case impl::MccCoordPairKind::COORDS_KIND_AZALT: + // NOTE: according to definition of astronomical azimuth it is counted from the South through the West, + // but in the ERFA the azimuth is counted from the North through the East!!! + // + x = co_lon + std::numbers::pi; + y = MccCCTE_ERFA::PI_2 - co_lat; // altitude to zenithal distance + type = "A"; + break; + case impl::MccCoordPairKind::COORDS_KIND_HADEC_OBS: + type = "H"; + x = co_lon; + y = co_lat; + break; + case impl::MccCoordPairKind::COORDS_KIND_RADEC_OBS: + type = "R"; + x = co_lon; + y = co_lat; + break; + case impl::MccCoordPairKind::COORDS_KIND_HADEC_APP: + type = "H"; + x = co_lon; + y = co_lat; + break; + case impl::MccCoordPairKind::COORDS_KIND_RADEC_APP: + type = "R"; + x = co_lon; + y = co_lat; + break; + default: + return MccCCTE_ERFAErrorCode::ERROR_UNSUPPORTED_COORD_PAIR; + }; + + int err = + eraAtoc13(type.c_str(), x, y, ERFA_DJM0, epoch.MJD(), dut1->count(), _currentState.lon, _currentState.lat, + _currentState.elev, pol_pos->x, pol_pos->y, pressure, _currentState.meteo.temperature, + _currentState.meteo.humidity, _currentState.wavelength, &ra, &dec); + + if (err == 1) { + ret = MccCCTE_ERFAErrorCode::ERROR_DUBIOUS_YEAR; + } else if (err == -1) { + ret = MccCCTE_ERFAErrorCode::ERROR_UNACCEPTABLE_DATE; + } + + if (ra) { + *ra_icrs = ra; + } + + if (dec) { + *dec_icrs = dec; + } + + return ret; + } +}; + + +static_assert(mcc_ccte_c, ""); + +} // namespace mcc::ccte::erfa diff --git a/mcc_ccte_iers.h b/mcc_ccte_iers.h new file mode 100644 index 0000000..799a243 --- /dev/null +++ b/mcc_ccte_iers.h @@ -0,0 +1,501 @@ +#pragma once + +/* MOUNT CONTROL COMPONENTS LIBRARY */ + + +/* Classes to represent IERS bulletins + * + * BULLETIN A: https://datacenter.iers.org/data/latestVersion/bulletinA.txt + * leapseconds: https://hpiers.obspm.fr/iers/bul/bulc/Leap_Second.dat + * + */ + +#include +#include + +#include "mcc_ccte_iers_default.h" +#include "mcc_traits.h" +#include "mcc_utils.h" + +namespace mcc::ccte::iers +{ + +class MccLeapSeconds final +{ +public: + typedef std::chrono::system_clock::time_point time_point_t; + typedef std::chrono::duration real_secs_t; // seconds duration in double + + MccLeapSeconds() + { + // create default values + std::istringstream ist(defaults::MCC_DEFAULT_LEAP_SECONDS_FILE); + + load(ist); + } + + ~MccLeapSeconds() = default; + + + time_point_t expireDate() const + { + return _expireDate; + } + + auto expireMJD() const + { + return _expireMJD; + } + + // load from stream + bool load(std::derived_from> auto& stream, char comment_sym = '#') + { + std::istringstream is; + double mjd; + unsigned day, month; + int year; + double tai_utc; + + decltype(_expireDate) edate; + std::vector db; + + for (std::string line; std::getline(stream, line);) { + auto sv = utils::trimSpaces(line, utils::TrimType::TRIM_LEFT); + + if (sv.size()) { + if (sv[0] == comment_sym) { // comment string + if (std::regex_match(line, expr_date_rx)) { + auto pos = line.find("on"); + sv = utils::trimSpaces(std::string_view{line.begin() + pos + 2, line.end()}, + utils::TrimType::TRIM_LEFT); + is.str({sv.begin(), sv.end()}); + is >> std::chrono::parse("%d %B %Y", edate); + is.clear(); + } + continue; + } + } else { + continue; + } + + if (std::regex_match(line, data_rx)) { + is.str(line); + is >> mjd >> day >> month >> year >> tai_utc; + db.emplace_back(mjd, std::chrono::year_month_day{std::chrono::year{year} / month / day}, tai_utc); + // db.emplace_back(mjd, + // std::chrono::year_month_day{std::chrono::year{year}, std::chrono::month{month}, + // std::chrono::day{day}}, + // tai_utc); + is.clear(); + + continue; + } + } + + if (db.empty()) { // keep previous data + return false; + } + + _expireDate = std::move(edate); + + // compute expire Julian Day + using namespace std::literals::chrono_literals; + + std::chrono::year_month_day ymd{std::chrono::floor(_expireDate)}; + + static constexpr std::chrono::year MIN_YEAR = -4799y; + + if (ymd.year() < MIN_YEAR) { + return -1; + } + if (!ymd.month().ok()) { + return -2; + } + + int64_t im = (unsigned)ymd.month(); + int64_t id = (unsigned)ymd.day(); + int64_t iy = (int)ymd.year(); + + int64_t my = (im - 14LL) / 12LL; + int64_t iypmy = iy + my; + + // integer part of result MJD + int64_t mjd_int = (1461LL * (iypmy + 4800LL)) / 4LL + (367LL * (im - 2LL - 12LL * my)) / 12LL - + (3LL * ((iypmy + 4900LL) / 100LL)) / 4LL + id - 2432076LL; + + _expireMJD = static_cast(mjd_int); + + + _db = std::move(db); + + return true; + } + + + bool load(traits::mcc_input_char_range auto const& filename, char comment_sym = '#') + { + std::ifstream fst; + if constexpr (std::same_as, std::string>) { + fst.open(filename); + } else { + fst.open(std::string{filename.begin(), filename.end()}); + } + + bool ok = fst.is_open(); + if (!ok) { + return false; + } + + ok = load(fst, comment_sym); + + fst.close(); + + return ok; + } + + + // std::optional operator[](const time_point_t& tp) const + std::optional operator[](const time_point_t& tp) const + { + if (tp > _expireDate) { // ???????!!!!!!!!!!! + return std::nullopt; + // return _db.back().tai_utc; + } + + std::chrono::year_month_day ymd{std::chrono::floor(tp)}; + + for (auto const& el : _db | std::views::reverse) { + if (ymd >= el.ymd) { + // return el.tai_utc; + return real_secs_t{el.tai_utc}; + } + } + + return std::nullopt; + } + + // std::optional operator[](const double& mjd) const + std::optional operator[](const double& mjd) const + { + double e_mjd; + + if (mjd > _expireMJD) { // ???????!!!!!!!!!!! + return std::nullopt; + // return _db.back().tai_utc; + } + + for (auto const& el : _db | std::views::reverse) { + if (mjd >= el.mjd) { + return real_secs_t{el.tai_utc}; + } + } + + return std::nullopt; + } + + + void dump(std::derived_from> auto& stream) const + { + stream << std::format("Leap seconds database expire date: {}", _expireDate) << '\n'; + for (auto const& el : _db) { + stream << std::format("{} {} {}", el.mjd, el.ymd, el.tai_utc) << '\n'; + } + } + + +private: + inline static const std::regex expr_date_rx{ + "^ *# *File +expires +on +[0-8]{1,2} " + "+(January|February|March|April|May|June|July|August|September|October|November|December) +[0-9]{4} *$"}; + + inline static const std::regex data_rx{"^ *[0-9]{5,}(\\.?[0-9]+) +[0-9]{1,2} +[0-9]{1,2} +[0-9]{4} +[0-9]{1,} *$"}; + + time_point_t _expireDate{}; + double _expireMJD{}; + + struct leapsecond_db_elem_t { + double mjd; + std::chrono::year_month_day ymd; + double tai_utc; // TAI-UTC in seconds + }; + + std::vector _db{}; +}; + + + +class MccIersBulletinA final +{ +public: + typedef std::chrono::system_clock::time_point time_point_t; + typedef std::chrono::duration real_secs_t; // seconds duration in double + + struct pole_pos_t { + double x, y; + }; + + struct date_range_t { + std::chrono::year_month_day begin; + std::chrono::year_month_day end; + }; + + struct date_range_mjd_t { + double begin; + double end; + }; + + MccIersBulletinA() + { + // create pre-defined (default-state) database + std::istringstream ist(defaults::MCC_DEFAULT_IERS_BULLETIN_A_FILE); + + load(ist); + } + + ~MccIersBulletinA() = default; + + std::chrono::system_clock::time_point bulletinDate() const + { + return _date; + } + + + date_range_t dateRange() const + { + return {_db.front().ymd, _db.back().ymd}; + } + + date_range_mjd_t dateRangeMJD() const + { + return {_db.front().mjd, _db.back().mjd}; + } + + + // double TT_TAI() const + real_secs_t TT_TAI() const + { + return real_secs_t{_tt_tai}; + } + + // DUT1 = UT1 - UTC + // std::optional DUT1(const time_point_t& tp) const + std::optional DUT1(const time_point_t& tp) const + { + // use of the closest date + std::chrono::year_month_day ymd{std::chrono::round(tp)}; + + if (ymd < _db.front().ymd) { + return std::nullopt; + } + + if (ymd > _db.back().ymd) { + return std::nullopt; + } + + for (auto const& el : _db) { + if (ymd <= el.ymd) { + return real_secs_t{el.dut1}; + } + } + + return std::nullopt; + } + + // std::optional DUT1(double mjd) const + std::optional DUT1(double mjd) const + { + mjd = std::round(mjd); // round to closest integer MJD + + if (mjd < _db.front().mjd) { + return std::nullopt; + } + + if (mjd > _db.back().mjd) { + return std::nullopt; + } + + for (auto const& el : _db) { + if (mjd <= el.mjd) { + return real_secs_t{el.dut1}; + } + } + + return std::nullopt; + } + + std::optional polarCoords(const time_point_t& tp) const + { + std::chrono::year_month_day ymd{std::chrono::round(tp)}; + + if (ymd < _db.front().ymd) { + return std::nullopt; + } + + if (ymd > _db.back().ymd) { + return std::nullopt; + } + + for (auto const& el : _db) { + if (ymd <= el.ymd) { + return pole_pos_t{el.x, el.y}; + } + } + + return std::nullopt; + } + + std::optional polarCoords(double mjd) const + { + mjd = std::round(mjd); // round to closest integer MJD + + if (mjd < _db.front().mjd) { + return std::nullopt; + } + + if (mjd > _db.back().mjd) { + return std::nullopt; + } + + for (auto const& el : _db) { + if (mjd <= el.mjd) { + return pole_pos_t{el.x, el.y}; + } + } + + return std::nullopt; + } + + bool load(std::derived_from> auto& stream, char comment_sym = '*') + { + std::vector db; + enum { TAB_STATE_SEEK, TAB_STATE_START }; + int tab_state = TAB_STATE_SEEK; + + int year; + unsigned month, day; + double mjd, x, y, dut1; + std::istringstream is; + decltype(_date) bdate; + double tt_tai; + + for (std::string line; std::getline(stream, line);) { + if (line.empty()) { + continue; + } + + auto sv = utils::trimSpaces(line, utils::TrimType::TRIM_LEFT); + + if (sv.size()) { + if (sv[0] == comment_sym) { // comment string + continue; + } + + if (tab_state == TAB_STATE_START) { + if (std::regex_match(sv.begin(), sv.end(), bull_tab_vals_rx)) { + // is.str({sv.begin(), sv.end()}); + is.str(line); + is >> year >> month >> day >> mjd >> x >> y >> dut1; + db.emplace_back(mjd, std::chrono::year_month_day{std::chrono::year{year} / month / day}, x, y, + dut1); + is.clear(); + } else { // end of the table - just stop parsing + break; + } + + continue; + } + + if (std::regex_match(sv.begin(), sv.end(), bull_date_rx)) { + is.str({sv.begin(), sv.end()}); + is >> std::chrono::parse("%d %B %Y", bdate); + continue; + } + + if (std::regex_match(sv.begin(), sv.end(), bull_tt_tai_rx)) { + is.str({sv.begin(), sv.end()}); + std::string dummy; + is >> dummy >> dummy >> dummy >> dummy >> tt_tai; + continue; + } + + if (std::regex_match(sv.begin(), sv.end(), bull_tab_title_rx)) { + tab_state = TAB_STATE_START; + continue; + } + + } else { // empty string (only spaces) + continue; + } + } + + if (db.empty()) { + return false; + } + + _date = std::move(bdate); + _tt_tai = tt_tai; + _db = std::move(db); + + return true; + } + + bool load(traits::mcc_input_char_range auto const& filename, char comment_sym = '*') + { + std::ifstream fst; + if constexpr (std::same_as, std::string>) { + fst.open(filename); + } else { + fst.open(std::string{filename.begin(), filename.end()}); + } + + bool ok = fst.is_open(); + if (!ok) { + return false; + } + + ok = load(fst, comment_sym); + + fst.close(); + + return ok; + } + + + void dump(std::derived_from> auto& stream) const + { + stream << std::format("Bulletin A issue date: {}", _date) << '\n'; + stream << std::format("TT-TAI: {}", _tt_tai) << '\n'; + for (auto const& el : _db) { + stream << std::format("{} {} {:6.4f} {:6.4f} {:7.5f}", el.mjd, el.ymd, el.x, el.y, el.dut1) << '\n'; + } + } + +private: + inline static const std::regex bull_date_rx{ + "^ *[0-9]{1,2} +(January|February|March|April|May|June|July|August|September|October|November|December) " + "+[0-9]{4,} +Vol\\. +[XMLCDVI]+ +No\\. +[0-9]+ *$"}; + + inline static const std::regex bull_tt_tai_rx{"^ *TT += +TAI +\\+ +[0-9]+\\.[0-9]+ +seconds *$"}; + + inline static const std::regex bull_tab_title_rx{"^ *MJD +x\\(arcsec\\) +y\\(arcsec\\) +UT1-UTC\\(sec\\) *$"}; + + inline static const std::regex bull_tab_vals_rx{ + "^ *[0-9]{4,} +[0-9]{1,2} +[0-9]{1,2} +[0-9]{5,} +[0-9]+\\.[0-9]+ +[0-9]+\\.[0-9]+ +[0-9]+\\.[0-9]+ *$"}; + + + time_point_t _date; + double _tt_tai; + + struct earth_orient_db_elem_t { + double mjd; + std::chrono::year_month_day ymd; + double x, y; // Polar coordinates in arcsecs + double dut1; // UT1-UTC in seconds + }; + + std::vector _db; +}; + + + +} // namespace mcc::ccte::iers diff --git a/mcc_ccte_iers_default.h b/mcc_ccte_iers_default.h new file mode 100644 index 0000000..7e1d0be --- /dev/null +++ b/mcc_ccte_iers_default.h @@ -0,0 +1,647 @@ +#pragma once + + +#include + + +namespace mcc::ccte::iers::defaults + +{ + +// https://hpiers.obspm.fr/iers/bul/bulc/Leap_Second.dat + +static std::string MCC_DEFAULT_LEAP_SECONDS_FILE = R"--( + +# Value of TAI-UTC in second valid beetween the initial value until +# the epoch given on the next line. The last line reads that NO +# leap second was introduced since the corresponding date +# Updated through IERS Bulletin 71 issued in January 2026 +# +# +# File expires on 28 December 2026 +# +# +# MJD Date TAI-UTC (s) +# day month year +# --- -------------- ------ +# + 41317.0 1 1 1972 10 + 41499.0 1 7 1972 11 + 41683.0 1 1 1973 12 + 42048.0 1 1 1974 13 + 42413.0 1 1 1975 14 + 42778.0 1 1 1976 15 + 43144.0 1 1 1977 16 + 43509.0 1 1 1978 17 + 43874.0 1 1 1979 18 + 44239.0 1 1 1980 19 + 44786.0 1 7 1981 20 + 45151.0 1 7 1982 21 + 45516.0 1 7 1983 22 + 46247.0 1 7 1985 23 + 47161.0 1 1 1988 24 + 47892.0 1 1 1990 25 + 48257.0 1 1 1991 26 + 48804.0 1 7 1992 27 + 49169.0 1 7 1993 28 + 49534.0 1 7 1994 29 + 50083.0 1 1 1996 30 + 50630.0 1 7 1997 31 + 51179.0 1 1 1999 32 + 53736.0 1 1 2006 33 + 54832.0 1 1 2009 34 + 56109.0 1 7 2012 35 + 57204.0 1 7 2015 36 + 57754.0 1 1 2017 37 +)--"; + + +// https://datacenter.iers.org/data/latestVersion/bulletinA.txt + +static std::string MCC_DEFAULT_IERS_BULLETIN_A_FILE = R"--( + + + ********************************************************************** + * * + * I E R S B U L L E T I N - A * + * * + * Rapid Service/Prediction of Earth Orientation * + ********************************************************************** + 8 January 2026 Vol. XXXIX No. 002 + ______________________________________________________________________ + GENERAL INFORMATION: + MJD = Julian Date - 2 400 000.5 days + UT2-UT1 = 0.022 sin(2*pi*T) - 0.012 cos(2*pi*T) + - 0.006 sin(4*pi*T) + 0.007 cos(4*pi*T) + where pi = 3.14159265... and T is the date in Besselian years. + TT = TAI + 32.184 seconds + DUT1= (UT1-UTC) transmitted with time signals + = +0.1 seconds beginning 10 July 2025 at 0000 UTC + Beginning 1 January 2017: + TAI-UTC = 37.000 000 seconds + *********************************************************************** + * ANNOUNCEMENTS: * + * * + * There will NOT be a leap second introduced in UTC * + * at the end of June 2026. * + * * + * The primary source for IERS Rapid Service/Prediction Center (RS/PC) * + * data products is the official IERS RS/PC website: * + * https://maia.usno.navy.mil * + * * + * IERS RS/PC products are also available from: * + * NASA CDDIS: https://cddis.nasa.gov/archive/products/iers/ * + * NASA CDDIS: ftps://gdc.cddis.eosdis.nasa.gov/products/iers/ * + * IERS Central Bureau: https://datacenter.iers.org/eop.php * + * * + * Questions about IERS RS/PC products can be emailed to: * + * eopcp@us.navy.mil * + * * + * Distribution statement A: * + * Approved for public release: distribution unlimited. * + * * + *********************************************************************** + ________________________________________________________________________ + The contributed observations used in the preparation of this Bulletin + are available at . The contributed analysis results are based + on data from Very Long Baseline Interferometry (VLBI), Satellite Laser + Ranging (SLR), the Global Positioning System (GPS) satellites, Lunar + Laser Ranging (LLR), and meteorological predictions of variations in + Atmospheric Angular Momentum (AAM). + ________________________________________________________________________ + + COMBINED EARTH ORIENTATION PARAMETERS: + + IERS Rapid Service + MJD x error y error UT1-UTC error + " " " " s s + 26 1 2 61042 0.10962 .00009 0.33249 .00009 0.074152 0.000020 + 26 1 3 61043 0.10827 .00009 0.33355 .00009 0.074367 0.000021 + 26 1 4 61044 0.10690 .00009 0.33455 .00009 0.074487 0.000020 + 26 1 5 61045 0.10554 .00009 0.33551 .00009 0.074361 0.000015 + 26 1 6 61046 0.10404 .00009 0.33628 .00009 0.073991 0.000015 + 26 1 7 61047 0.10253 .00009 0.33692 .00009 0.073470 0.000012 + 26 1 8 61048 0.10121 .00009 0.33746 .00009 0.072861 0.000008 + + IERS Final Values + MJD x y UT1-UTC + " " s + 25 11 2 60981 0.1750 0.3194 0.09220 + 25 11 3 60982 0.1735 0.3187 0.09112 + 25 11 4 60983 0.1718 0.3187 0.09005 + 25 11 5 60984 0.1699 0.3183 0.08916 + 25 11 6 60985 0.1679 0.3182 0.08854 + 25 11 7 60986 0.1659 0.3179 0.08822 + 25 11 8 60987 0.1640 0.3171 0.08814 + 25 11 9 60988 0.1630 0.3163 0.08819 + 25 11 10 60989 0.1625 0.3158 0.08820 + 25 11 11 60990 0.1615 0.3153 0.08801 + 25 11 12 60991 0.1602 0.3151 0.08763 + 25 11 13 60992 0.1583 0.3154 0.08711 + 25 11 14 60993 0.1564 0.3157 0.08644 + 25 11 15 60994 0.1545 0.3160 0.08566 + 25 11 16 60995 0.1530 0.3163 0.08494 + 25 11 17 60996 0.1511 0.3167 0.08433 + 25 11 18 60997 0.1491 0.3165 0.08390 + 25 11 19 60998 0.1474 0.3163 0.08366 + 25 11 20 60999 0.1456 0.3161 0.08357 + 25 11 21 61000 0.1437 0.3157 0.08363 + 25 11 22 61001 0.1419 0.3149 0.08381 + 25 11 23 61002 0.1398 0.3143 0.08403 + 25 11 24 61003 0.1380 0.3136 0.08426 + 25 11 25 61004 0.1373 0.3137 0.08431 + 25 11 26 61005 0.1360 0.3146 0.08417 + 25 11 27 61006 0.1351 0.3149 0.08377 + 25 11 28 61007 0.1343 0.3153 0.08305 + 25 11 29 61008 0.1334 0.3153 0.08209 + 25 11 30 61009 0.1325 0.3157 0.08097 + 25 12 1 61010 0.1316 0.3160 0.07984 + + _______________________________________________________________________ + + PREDICTIONS: + The following formulas will not reproduce the predictions given below, + but may be used to extend the predictions beyond the end of this table. + + x = 0.1611 - 0.0626 cos A - 0.1221 sin A + 0.0025 cos C + 0.0585 sin C + y = 0.3836 - 0.1091 cos A + 0.0516 sin A + 0.0585 cos C - 0.0025 sin C + UT1-UTC = 0.0617 + 0.00005 (MJD - 61056) - (UT2-UT1) + + where A = 2*pi*(MJD-61048)/365.25 and C = 2*pi*(MJD-61048)/435. + + TAI-UTC(MJD 61049) = 37.0 + The accuracy may be estimated from the expressions: + S x,y = 0.00068 (MJD-61048)**0.80 S t = 0.00025 (MJD-61048)**0.75 + Estimated accuracies are: Predictions 10 d 20 d 30 d 40 d + Polar coord's 0.004 0.007 0.010 0.013 + UT1-UTC 0.0014 0.0024 0.0032 0.0040 + + MJD x(arcsec) y(arcsec) UT1-UTC(sec) + 2026 1 9 61049 0.1001 0.3380 0.07228 + 2026 1 10 61050 0.0993 0.3385 0.07180 + 2026 1 11 61051 0.0985 0.3390 0.07149 + 2026 1 12 61052 0.0978 0.3396 0.07136 + 2026 1 13 61053 0.0971 0.3403 0.07142 + 2026 1 14 61054 0.0964 0.3411 0.07168 + 2026 1 15 61055 0.0957 0.3418 0.07209 + 2026 1 16 61056 0.0949 0.3426 0.07260 + 2026 1 17 61057 0.0942 0.3434 0.07313 + 2026 1 18 61058 0.0935 0.3442 0.07360 + 2026 1 19 61059 0.0928 0.3450 0.07391 + 2026 1 20 61060 0.0921 0.3458 0.07400 + 2026 1 21 61061 0.0915 0.3466 0.07380 + 2026 1 22 61062 0.0909 0.3474 0.07332 + 2026 1 23 61063 0.0903 0.3482 0.07264 + 2026 1 24 61064 0.0897 0.3490 0.07185 + 2026 1 25 61065 0.0892 0.3499 0.07110 + 2026 1 26 61066 0.0886 0.3507 0.07051 + 2026 1 27 61067 0.0881 0.3516 0.07015 + 2026 1 28 61068 0.0876 0.3524 0.07004 + 2026 1 29 61069 0.0872 0.3533 0.07016 + 2026 1 30 61070 0.0867 0.3542 0.07040 + 2026 1 31 61071 0.0863 0.3551 0.07062 + 2026 2 1 61072 0.0858 0.3560 0.07069 + 2026 2 2 61073 0.0855 0.3569 0.07052 + 2026 2 3 61074 0.0851 0.3578 0.07011 + 2026 2 4 61075 0.0847 0.3587 0.06952 + 2026 2 5 61076 0.0844 0.3596 0.06884 + 2026 2 6 61077 0.0841 0.3605 0.06818 + 2026 2 7 61078 0.0838 0.3615 0.06763 + 2026 2 8 61079 0.0835 0.3624 0.06723 + 2026 2 9 61080 0.0832 0.3634 0.06700 + 2026 2 10 61081 0.0830 0.3643 0.06696 + 2026 2 11 61082 0.0828 0.3653 0.06706 + 2026 2 12 61083 0.0826 0.3662 0.06727 + 2026 2 13 61084 0.0824 0.3672 0.06753 + 2026 2 14 61085 0.0822 0.3682 0.06774 + 2026 2 15 61086 0.0821 0.3692 0.06784 + 2026 2 16 61087 0.0820 0.3702 0.06774 + 2026 2 17 61088 0.0819 0.3711 0.06738 + 2026 2 18 61089 0.0818 0.3721 0.06675 + 2026 2 19 61090 0.0818 0.3731 0.06590 + 2026 2 20 61091 0.0817 0.3741 0.06493 + 2026 2 21 61092 0.0817 0.3751 0.06395 + 2026 2 22 61093 0.0817 0.3761 0.06311 + 2026 2 23 61094 0.0818 0.3771 0.06250 + 2026 2 24 61095 0.0818 0.3781 0.06215 + 2026 2 25 61096 0.0819 0.3792 0.06203 + 2026 2 26 61097 0.0820 0.3802 0.06204 + 2026 2 27 61098 0.0821 0.3812 0.06206 + 2026 2 28 61099 0.0823 0.3822 0.06196 + 2026 3 1 61100 0.0824 0.3832 0.06165 + 2026 3 2 61101 0.0826 0.3842 0.06111 + 2026 3 3 61102 0.0828 0.3852 0.06037 + 2026 3 4 61103 0.0831 0.3862 0.05951 + 2026 3 5 61104 0.0833 0.3872 0.05864 + 2026 3 6 61105 0.0836 0.3882 0.05787 + 2026 3 7 61106 0.0839 0.3893 0.05726 + 2026 3 8 61107 0.0842 0.3903 0.05686 + 2026 3 9 61108 0.0846 0.3913 0.05667 + 2026 3 10 61109 0.0849 0.3922 0.05667 + 2026 3 11 61110 0.0853 0.3932 0.05681 + 2026 3 12 61111 0.0857 0.3942 0.05703 + 2026 3 13 61112 0.0861 0.3952 0.05725 + 2026 3 14 61113 0.0866 0.3962 0.05737 + 2026 3 15 61114 0.0870 0.3972 0.05732 + 2026 3 16 61115 0.0875 0.3981 0.05703 + 2026 3 17 61116 0.0880 0.3991 0.05647 + 2026 3 18 61117 0.0886 0.4000 0.05564 + 2026 3 19 61118 0.0891 0.4010 0.05462 + 2026 3 20 61119 0.0897 0.4019 0.05355 + 2026 3 21 61120 0.0903 0.4029 0.05256 + 2026 3 22 61121 0.0909 0.4038 0.05180 + 2026 3 23 61122 0.0916 0.4047 0.05132 + 2026 3 24 61123 0.0922 0.4056 0.05111 + 2026 3 25 61124 0.0929 0.4065 0.05107 + 2026 3 26 61125 0.0936 0.4074 0.05108 + 2026 3 27 61126 0.0943 0.4083 0.05100 + 2026 3 28 61127 0.0950 0.4092 0.05075 + 2026 3 29 61128 0.0958 0.4101 0.05028 + 2026 3 30 61129 0.0966 0.4109 0.04959 + 2026 3 31 61130 0.0974 0.4118 0.04876 + 2026 4 1 61131 0.0982 0.4126 0.04787 + 2026 4 2 61132 0.0990 0.4134 0.04702 + 2026 4 3 61133 0.0998 0.4142 0.04629 + 2026 4 4 61134 0.1007 0.4150 0.04574 + 2026 4 5 61135 0.1016 0.4158 0.04540 + 2026 4 6 61136 0.1025 0.4166 0.04526 + 2026 4 7 61137 0.1034 0.4174 0.04528 + 2026 4 8 61138 0.1044 0.4181 0.04540 + 2026 4 9 61139 0.1053 0.4188 0.04556 + 2026 4 10 61140 0.1063 0.4196 0.04566 + 2026 4 11 61141 0.1073 0.4203 0.04563 + 2026 4 12 61142 0.1083 0.4210 0.04539 + 2026 4 13 61143 0.1093 0.4217 0.04489 + 2026 4 14 61144 0.1103 0.4223 0.04411 + 2026 4 15 61145 0.1114 0.4230 0.04311 + 2026 4 16 61146 0.1124 0.4236 0.04198 + 2026 4 17 61147 0.1135 0.4242 0.04088 + 2026 4 18 61148 0.1146 0.4248 0.03995 + 2026 4 19 61149 0.1157 0.4254 0.03929 + 2026 4 20 61150 0.1168 0.4260 0.03893 + 2026 4 21 61151 0.1180 0.4265 0.03881 + 2026 4 22 61152 0.1191 0.4271 0.03879 + 2026 4 23 61153 0.1203 0.4276 0.03874 + 2026 4 24 61154 0.1214 0.4281 0.03855 + 2026 4 25 61155 0.1226 0.4286 0.03815 + 2026 4 26 61156 0.1238 0.4291 0.03757 + 2026 4 27 61157 0.1250 0.4295 0.03685 + 2026 4 28 61158 0.1262 0.4299 0.03606 + 2026 4 29 61159 0.1275 0.4304 0.03532 + 2026 4 30 61160 0.1287 0.4308 0.03468 + 2026 5 1 61161 0.1300 0.4311 0.03422 + 2026 5 2 61162 0.1312 0.4315 0.03397 + 2026 5 3 61163 0.1325 0.4318 0.03394 + 2026 5 4 61164 0.1338 0.4322 0.03410 + 2026 5 5 61165 0.1350 0.4325 0.03439 + 2026 5 6 61166 0.1363 0.4327 0.03475 + 2026 5 7 61167 0.1376 0.4330 0.03509 + 2026 5 8 61168 0.1389 0.4332 0.03536 + 2026 5 9 61169 0.1402 0.4335 0.03547 + 2026 5 10 61170 0.1416 0.4337 0.03538 + 2026 5 11 61171 0.1429 0.4339 0.03505 + 2026 5 12 61172 0.1442 0.4340 0.03452 + 2026 5 13 61173 0.1456 0.4342 0.03383 + 2026 5 14 61174 0.1469 0.4343 0.03311 + 2026 5 15 61175 0.1482 0.4344 0.03249 + 2026 5 16 61176 0.1496 0.4345 0.03211 + 2026 5 17 61177 0.1509 0.4345 0.03204 + 2026 5 18 61178 0.1523 0.4345 0.03225 + 2026 5 19 61179 0.1537 0.4346 0.03262 + 2026 5 20 61180 0.1550 0.4346 0.03301 + 2026 5 21 61181 0.1564 0.4345 0.03328 + 2026 5 22 61182 0.1577 0.4345 0.03336 + 2026 5 23 61183 0.1591 0.4344 0.03325 + 2026 5 24 61184 0.1605 0.4343 0.03299 + 2026 5 25 61185 0.1618 0.4342 0.03268 + 2026 5 26 61186 0.1632 0.4341 0.03241 + 2026 5 27 61187 0.1646 0.4339 0.03224 + 2026 5 28 61188 0.1659 0.4338 0.03225 + 2026 5 29 61189 0.1673 0.4336 0.03246 + 2026 5 30 61190 0.1686 0.4333 0.03289 + 2026 5 31 61191 0.1700 0.4331 0.03352 + 2026 6 1 61192 0.1713 0.4328 0.03429 + 2026 6 2 61193 0.1727 0.4326 0.03515 + 2026 6 3 61194 0.1740 0.4323 0.03602 + 2026 6 4 61195 0.1754 0.4319 0.03683 + 2026 6 5 61196 0.1767 0.4316 0.03751 + 2026 6 6 61197 0.1781 0.4312 0.03801 + 2026 6 7 61198 0.1794 0.4308 0.03831 + 2026 6 8 61199 0.1807 0.4304 0.03841 + 2026 6 9 61200 0.1820 0.4300 0.03835 + 2026 6 10 61201 0.1833 0.4295 0.03823 + 2026 6 11 61202 0.1846 0.4291 0.03815 + 2026 6 12 61203 0.1859 0.4286 0.03824 + 2026 6 13 61204 0.1872 0.4280 0.03860 + 2026 6 14 61205 0.1885 0.4275 0.03924 + 2026 6 15 61206 0.1897 0.4270 0.04009 + 2026 6 16 61207 0.1910 0.4264 0.04101 + 2026 6 17 61208 0.1922 0.4258 0.04185 + 2026 6 18 61209 0.1935 0.4252 0.04250 + 2026 6 19 61210 0.1947 0.4245 0.04293 + 2026 6 20 61211 0.1959 0.4239 0.04317 + 2026 6 21 61212 0.1971 0.4232 0.04333 + 2026 6 22 61213 0.1983 0.4225 0.04352 + 2026 6 23 61214 0.1995 0.4218 0.04381 + 2026 6 24 61215 0.2007 0.4211 0.04428 + 2026 6 25 61216 0.2018 0.4203 0.04496 + 2026 6 26 61217 0.2030 0.4195 0.04586 + 2026 6 27 61218 0.2041 0.4187 0.04695 + 2026 6 28 61219 0.2052 0.4179 0.04820 + 2026 6 29 61220 0.2063 0.4171 0.04955 + 2026 6 30 61221 0.2074 0.4162 0.05092 + 2026 7 1 61222 0.2085 0.4154 0.05224 + 2026 7 2 61223 0.2095 0.4145 0.05344 + 2026 7 3 61224 0.2106 0.4136 0.05447 + 2026 7 4 61225 0.2116 0.4127 0.05530 + 2026 7 5 61226 0.2126 0.4118 0.05595 + 2026 7 6 61227 0.2136 0.4108 0.05644 + 2026 7 7 61228 0.2146 0.4098 0.05686 + 2026 7 8 61229 0.2155 0.4088 0.05730 + 2026 7 9 61230 0.2164 0.4078 0.05787 + 2026 7 10 61231 0.2174 0.4068 0.05866 + 2026 7 11 61232 0.2183 0.4058 0.05971 + 2026 7 12 61233 0.2191 0.4048 0.06099 + 2026 7 13 61234 0.2200 0.4037 0.06238 + 2026 7 14 61235 0.2208 0.4026 0.06374 + 2026 7 15 61236 0.2217 0.4015 0.06490 + 2026 7 16 61237 0.2225 0.4004 0.06580 + 2026 7 17 61238 0.2232 0.3993 0.06643 + 2026 7 18 61239 0.2240 0.3982 0.06686 + 2026 7 19 61240 0.2247 0.3970 0.06720 + 2026 7 20 61241 0.2255 0.3959 0.06757 + 2026 7 21 61242 0.2262 0.3947 0.06804 + 2026 7 22 61243 0.2268 0.3935 0.06865 + 2026 7 23 61244 0.2275 0.3923 0.06942 + 2026 7 24 61245 0.2281 0.3911 0.07035 + 2026 7 25 61246 0.2287 0.3899 0.07139 + 2026 7 26 61247 0.2293 0.3887 0.07253 + 2026 7 27 61248 0.2299 0.3875 0.07369 + 2026 7 28 61249 0.2304 0.3862 0.07483 + 2026 7 29 61250 0.2309 0.3849 0.07589 + 2026 7 30 61251 0.2314 0.3837 0.07681 + 2026 7 31 61252 0.2319 0.3824 0.07755 + 2026 8 1 61253 0.2323 0.3811 0.07812 + 2026 8 2 61254 0.2327 0.3798 0.07854 + 2026 8 3 61255 0.2331 0.3785 0.07889 + 2026 8 4 61256 0.2335 0.3772 0.07925 + 2026 8 5 61257 0.2338 0.3759 0.07972 + 2026 8 6 61258 0.2342 0.3746 0.08039 + 2026 8 7 61259 0.2344 0.3733 0.08130 + 2026 8 8 61260 0.2347 0.3719 0.08241 + 2026 8 9 61261 0.2350 0.3706 0.08365 + 2026 8 10 61262 0.2352 0.3692 0.08486 + 2026 8 11 61263 0.2354 0.3679 0.08590 + 2026 8 12 61264 0.2355 0.3665 0.08667 + 2026 8 13 61265 0.2357 0.3652 0.08710 + 2026 8 14 61266 0.2358 0.3638 0.08724 + 2026 8 15 61267 0.2359 0.3624 0.08725 + 2026 8 16 61268 0.2359 0.3611 0.08727 + 2026 8 17 61269 0.2360 0.3597 0.08741 + 2026 8 18 61270 0.2360 0.3583 0.08772 + 2026 8 19 61271 0.2360 0.3570 0.08823 + 2026 8 20 61272 0.2359 0.3556 0.08889 + 2026 8 21 61273 0.2359 0.3542 0.08975 + 2026 8 22 61274 0.2358 0.3528 0.09075 + 2026 8 23 61275 0.2356 0.3515 0.09173 + 2026 8 24 61276 0.2355 0.3501 0.09267 + 2026 8 25 61277 0.2353 0.3487 0.09354 + 2026 8 26 61278 0.2351 0.3473 0.09418 + 2026 8 27 61279 0.2349 0.3460 0.09450 + 2026 8 28 61280 0.2346 0.3446 0.09461 + 2026 8 29 61281 0.2344 0.3432 0.09454 + 2026 8 30 61282 0.2340 0.3419 0.09433 + 2026 8 31 61283 0.2337 0.3405 0.09408 + 2026 9 1 61284 0.2334 0.3391 0.09392 + 2026 9 2 61285 0.2330 0.3378 0.09389 + 2026 9 3 61286 0.2326 0.3364 0.09406 + 2026 9 4 61287 0.2321 0.3351 0.09437 + 2026 9 5 61288 0.2317 0.3337 0.09483 + 2026 9 6 61289 0.2312 0.3324 0.09533 + 2026 9 7 61290 0.2306 0.3311 0.09572 + 2026 9 8 61291 0.2301 0.3298 0.09587 + 2026 9 9 61292 0.2295 0.3285 0.09576 + 2026 9 10 61293 0.2289 0.3272 0.09541 + 2026 9 11 61294 0.2283 0.3259 0.09492 + 2026 9 12 61295 0.2277 0.3246 0.09452 + 2026 9 13 61296 0.2270 0.3233 0.09420 + 2026 9 14 61297 0.2263 0.3220 0.09410 + 2026 9 15 61298 0.2256 0.3208 0.09416 + 2026 9 16 61299 0.2248 0.3195 0.09433 + 2026 9 17 61300 0.2241 0.3183 0.09465 + 2026 9 18 61301 0.2233 0.3170 0.09510 + 2026 9 19 61302 0.2225 0.3158 0.09562 + 2026 9 20 61303 0.2216 0.3146 0.09615 + 2026 9 21 61304 0.2208 0.3134 0.09657 + 2026 9 22 61305 0.2199 0.3122 0.09690 + 2026 9 23 61306 0.2190 0.3110 0.09704 + 2026 9 24 61307 0.2180 0.3099 0.09702 + 2026 9 25 61308 0.2171 0.3087 0.09681 + 2026 9 26 61309 0.2161 0.3076 0.09642 + 2026 9 27 61310 0.2151 0.3065 0.09591 + 2026 9 28 61311 0.2141 0.3054 0.09537 + 2026 9 29 61312 0.2130 0.3043 0.09501 + 2026 9 30 61313 0.2119 0.3032 0.09489 + 2026 10 1 61314 0.2109 0.3022 0.09500 + 2026 10 2 61315 0.2097 0.3011 0.09526 + 2026 10 3 61316 0.2086 0.3001 0.09568 + 2026 10 4 61317 0.2075 0.2991 0.09602 + 2026 10 5 61318 0.2063 0.2981 0.09613 + 2026 10 6 61319 0.2051 0.2971 0.09602 + 2026 10 7 61320 0.2039 0.2962 0.09573 + 2026 10 8 61321 0.2027 0.2952 0.09526 + 2026 10 9 61322 0.2014 0.2943 0.09470 + 2026 10 10 61323 0.2001 0.2934 0.09420 + 2026 10 11 61324 0.1989 0.2925 0.09382 + 2026 10 12 61325 0.1976 0.2917 0.09360 + 2026 10 13 61326 0.1962 0.2908 0.09354 + 2026 10 14 61327 0.1949 0.2900 0.09367 + 2026 10 15 61328 0.1935 0.2892 0.09395 + 2026 10 16 61329 0.1922 0.2884 0.09436 + 2026 10 17 61330 0.1908 0.2876 0.09484 + 2026 10 18 61331 0.1894 0.2869 0.09525 + 2026 10 19 61332 0.1880 0.2862 0.09550 + 2026 10 20 61333 0.1865 0.2855 0.09558 + 2026 10 21 61334 0.1851 0.2848 0.09543 + 2026 10 22 61335 0.1836 0.2841 0.09503 + 2026 10 23 61336 0.1821 0.2835 0.09443 + 2026 10 24 61337 0.1807 0.2829 0.09372 + 2026 10 25 61338 0.1792 0.2823 0.09295 + 2026 10 26 61339 0.1776 0.2817 0.09229 + 2026 10 27 61340 0.1761 0.2812 0.09186 + 2026 10 28 61341 0.1746 0.2807 0.09174 + 2026 10 29 61342 0.1730 0.2802 0.09188 + 2026 10 30 61343 0.1715 0.2797 0.09217 + 2026 10 31 61344 0.1699 0.2792 0.09250 + 2026 11 1 61345 0.1683 0.2788 0.09272 + 2026 11 2 61346 0.1667 0.2784 0.09267 + 2026 11 3 61347 0.1651 0.2780 0.09243 + 2026 11 4 61348 0.1635 0.2777 0.09199 + 2026 11 5 61349 0.1619 0.2773 0.09144 + 2026 11 6 61350 0.1603 0.2770 0.09088 + 2026 11 7 61351 0.1587 0.2767 0.09046 + 2026 11 8 61352 0.1571 0.2765 0.09016 + 2026 11 9 61353 0.1554 0.2763 0.09004 + 2026 11 10 61354 0.1538 0.2760 0.09011 + 2026 11 11 61355 0.1521 0.2759 0.09033 + 2026 11 12 61356 0.1505 0.2757 0.09067 + 2026 11 13 61357 0.1488 0.2756 0.09106 + 2026 11 14 61358 0.1471 0.2755 0.09148 + 2026 11 15 61359 0.1455 0.2754 0.09178 + 2026 11 16 61360 0.1438 0.2753 0.09198 + 2026 11 17 61361 0.1421 0.2753 0.09203 + 2026 11 18 61362 0.1405 0.2753 0.09194 + 2026 11 19 61363 0.1388 0.2753 0.09161 + 2026 11 20 61364 0.1371 0.2754 0.09115 + 2026 11 21 61365 0.1354 0.2755 0.09063 + 2026 11 22 61366 0.1338 0.2756 0.09016 + 2026 11 23 61367 0.1321 0.2757 0.08988 + 2026 11 24 61368 0.1304 0.2759 0.08982 + 2026 11 25 61369 0.1287 0.2760 0.09000 + 2026 11 26 61370 0.1271 0.2762 0.09038 + 2026 11 27 61371 0.1254 0.2765 0.09073 + 2026 11 28 61372 0.1237 0.2767 0.09096 + 2026 11 29 61373 0.1221 0.2770 0.09110 + 2026 11 30 61374 0.1204 0.2773 0.09103 + 2026 12 1 61375 0.1188 0.2777 0.09070 + 2026 12 2 61376 0.1171 0.2780 0.09027 + 2026 12 3 61377 0.1155 0.2784 0.08987 + 2026 12 4 61378 0.1139 0.2788 0.08951 + 2026 12 5 61379 0.1122 0.2793 0.08932 + 2026 12 6 61380 0.1106 0.2797 0.08929 + 2026 12 7 61381 0.1090 0.2802 0.08941 + 2026 12 8 61382 0.1074 0.2807 0.08977 + 2026 12 9 61383 0.1058 0.2813 0.09031 + 2026 12 10 61384 0.1042 0.2819 0.09092 + 2026 12 11 61385 0.1026 0.2824 0.09153 + 2026 12 12 61386 0.1011 0.2831 0.09210 + 2026 12 13 61387 0.0995 0.2837 0.09261 + 2026 12 14 61388 0.0980 0.2844 0.09296 + 2026 12 15 61389 0.0964 0.2851 0.09308 + 2026 12 16 61390 0.0949 0.2858 0.09298 + 2026 12 17 61391 0.0934 0.2865 0.09271 + 2026 12 18 61392 0.0919 0.2873 0.09223 + 2026 12 19 61393 0.0904 0.2881 0.09183 + 2026 12 20 61394 0.0889 0.2889 0.09151 + 2026 12 21 61395 0.0875 0.2897 0.09140 + 2026 12 22 61396 0.0860 0.2906 0.09146 + 2026 12 23 61397 0.0846 0.2914 0.09172 + 2026 12 24 61398 0.0832 0.2923 0.09217 + 2026 12 25 61399 0.0818 0.2933 0.09256 + 2026 12 26 61400 0.0804 0.2942 0.09281 + 2026 12 27 61401 0.0791 0.2952 0.09278 + 2026 12 28 61402 0.0777 0.2962 0.09251 + 2026 12 29 61403 0.0764 0.2972 0.09213 + 2026 12 30 61404 0.0751 0.2982 0.09173 + 2026 12 31 61405 0.0738 0.2993 0.09140 + 2027 1 1 61406 0.0725 0.3004 0.09123 + 2027 1 2 61407 0.0713 0.3015 0.09132 + 2027 1 3 61408 0.0700 0.3026 0.09160 + 2027 1 4 61409 0.0688 0.3037 0.09200 + 2027 1 5 61410 0.0676 0.3049 0.09264 + 2027 1 6 61411 0.0665 0.3061 0.09344 + 2027 1 7 61412 0.0653 0.3072 0.09426 + 2027 1 8 61413 0.0642 0.3085 0.09509 + These predictions are based on all announced leap seconds. + + CELESTIAL POLE OFFSET SERIES: + NEOS Celestial Pole Offset Series + MJD dpsi error deps error + (msec. of arc) + 61026 -114.45 1.33 -7.19 0.16 + 61027 -114.43 1.33 -7.42 0.16 + 61028 -114.48 1.33 -7.64 0.16 + 61029 -114.51 1.19 -7.67 0.18 + 61030 -114.39 1.19 -7.49 0.18 + 61031 -114.09 1.24 -7.26 0.16 + 61032 -113.74 1.35 -7.13 0.06 + 61033 -113.52 1.35 -7.11 0.06 + + IERS Celestial Pole Offset Final Series + MJD dpsi deps + (msec. of arc) + 60981 -117.6 -9.0 + 60982 -117.8 -8.8 + 60983 -118.0 -8.6 + 60984 -117.8 -8.6 + 60985 -117.5 -8.8 + 60986 -117.1 -8.9 + 60987 -116.8 -8.7 + 60988 -116.9 -8.5 + 60989 -117.0 -8.6 + 60990 -116.9 -8.8 + 60991 -116.6 -8.8 + 60992 -116.5 -8.5 + 60993 -116.5 -8.0 + 60994 -116.6 -7.7 + 60995 -116.6 -7.6 + 60996 -116.4 -7.5 + 60997 -116.1 -7.5 + 60998 -115.6 -7.8 + 60999 -115.5 -8.3 + 61000 -115.9 -8.6 + 61001 -116.0 -8.6 + 61002 -115.9 -8.5 + 61003 -115.7 -8.3 + 61004 -115.4 -8.2 + 61005 -115.1 -8.2 + 61006 -114.7 -8.1 + 61007 -114.4 -7.9 + 61008 -114.3 -7.9 + 61009 -114.6 -7.8 + 61010 -115.2 -7.6 + + IAU2000A Celestial Pole Offset Series + MJD dX error dY error + (msec. of arc) + 61026 0.512 0.531 -0.092 0.161 + 61027 0.519 0.531 -0.101 0.161 + 61028 0.523 0.531 -0.107 0.161 + 61029 0.527 0.474 -0.112 0.176 + 61030 0.530 0.474 -0.114 0.176 + 61031 0.533 0.494 -0.114 0.156 + 61032 0.536 0.536 -0.113 0.059 + 61033 0.539 0.536 -0.111 0.059 + + + IAU2000A Celestial Pole Offset Final Series + MJD dX dY + (msec. of arc) + 60981 0.40 0.03 + 60982 0.38 0.02 + 60983 0.37 0.00 + 60984 0.42 -0.05 + 60985 0.41 -0.05 + 60986 0.34 -0.00 + 60987 0.33 0.01 + 60988 0.36 -0.01 + 60989 0.41 -0.04 + 60990 0.46 -0.06 + 60991 0.45 -0.05 + 60992 0.42 -0.02 + 60993 0.39 0.01 + 60994 0.33 0.07 + 60995 0.29 0.12 + 60996 0.30 0.14 + 60997 0.38 0.10 + 60998 0.59 -0.02 + 60999 0.62 -0.11 + 61000 0.51 -0.14 + 61001 0.41 -0.14 + 61002 0.35 -0.10 + 61003 0.32 -0.06 + 61004 0.33 -0.03 + 61005 0.38 -0.07 + 61006 0.47 -0.10 + 61007 0.57 -0.11 + 61008 0.57 -0.10 + 61009 0.48 -0.08 + 61010 0.35 -0.06 + +)--"; + + + +} // namespace mcc::ccte::iers::defaults + diff --git a/mcc_concepts.h b/mcc_concepts.h index e69de29..2f9df36 100644 --- a/mcc_concepts.h +++ b/mcc_concepts.h @@ -0,0 +1,967 @@ +#pragma once + + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * COMPONENT CLASSES CONCEPTS * + * * + ****************************************************************************************/ + + +#include +#include +#include + + +#include "mcc_angle.h" +#include "mcc_traits.h" + +namespace mcc +{ + + +/* LIBRARY-WIDE CONCEPT FOR LOGGER CLASS */ + +template +concept mcc_logger_c = requires(T t, const T t_const) { + { t.logError(std::declval()) }; + { t.logDebug(std::declval()) }; + { t.logWarn(std::declval()) }; + { t.logInfo(std::declval()) }; + { t.logTrace(std::declval()) }; +}; + + +/* CLASS TO EMULATE NO LOGGING */ +struct MccNullLogger { + void logError(const std::string&) {} + void logDebug(const std::string&) {} + void logWarn(const std::string&) {} + void logInfo(const std::string&) {} + void logTrace(const std::string&) {} +}; + + + +/* LIBRARY-WIDE TYPES DEFINITION OF OPERATIONAL ERROR */ +/* AND CLASS METHODS RETURNED VALUE */ + +template +concept mcc_error_c = + std::formattable && std::default_initializable && (std::convertible_to || requires(const T t) { + (bool)T() == false; // default constucted value must be a "non-error"! + }); + + +template +DefErrT mcc_deduced_err(ErrT const& err, DefErrT const& default_err) +{ + if constexpr (std::same_as) { + return err; + } else { + return default_err; + } +} + + +template +concept mcc_retval_c = requires(T t) { + // + [](std::expected) {}(t); +}; + + +// deduce an error from mcc_retval_c and default error value +template RetT, mcc_error_c DefErrT> +DefErrT mcc_deduced_err(RetT const& ret, DefErrT const& default_err) +{ + if (ret) { + return DefErrT{}; // no error + } + + if constexpr (std::same_as) { + return ret.error(); + } else { + return default_err; + } +} + + +/* MOUNT CONSTRUCTION-RELATED STUFF */ + +// mount construction type (only the most common ones) +enum class MccMountType : uint8_t { GERMAN_TYPE, FORK_TYPE, CROSSAXIS_TYPE, ALTAZ_TYPE }; + +template +static constexpr std::string_view MccMountTypeStr = TYPE == MccMountType::GERMAN_TYPE ? "GERMAN" + : TYPE == MccMountType::FORK_TYPE ? "FORK" + : TYPE == MccMountType::CROSSAXIS_TYPE ? "CROSSAXIS" + : TYPE == MccMountType::ALTAZ_TYPE ? "ALTAZ" + : "UNKNOWN"; + +template +static constexpr bool mcc_is_equatorial_mount = TYPE == MccMountType::GERMAN_TYPE ? true + : TYPE == MccMountType::FORK_TYPE ? true + : TYPE == MccMountType::CROSSAXIS_TYPE ? true + : TYPE == MccMountType::ALTAZ_TYPE ? false + : false; +template +static constexpr bool mcc_is_altaz_mount = TYPE == MccMountType::GERMAN_TYPE ? false + : TYPE == MccMountType::FORK_TYPE ? false + : TYPE == MccMountType::CROSSAXIS_TYPE ? false + : TYPE == MccMountType::ALTAZ_TYPE ? true + : false; + +static consteval bool mccIsEquatorialMount(const MccMountType type) +{ + return type == MccMountType::GERMAN_TYPE ? true + : type == MccMountType::FORK_TYPE ? true + : type == MccMountType::CROSSAXIS_TYPE ? true + : type == MccMountType::ALTAZ_TYPE ? false + : false; +}; + +static consteval bool mccIsAltAzMount(const MccMountType type) +{ + return type == MccMountType::GERMAN_TYPE ? false + : type == MccMountType::FORK_TYPE ? false + : type == MccMountType::CROSSAXIS_TYPE ? false + : type == MccMountType::ALTAZ_TYPE ? true + : false; +}; + + + +/* FLOATING-POINT LIKE CLASS CONCEPT */ + +template +concept mcc_fp_type_like_c = + std::floating_point || + (std::convertible_to && std::constructible_from && std::default_initializable); + + + +/* GEOMETRICAL ANGLE REPRESENTATION CLASS CONCEPT */ + +template +concept mcc_angle_c = mcc_fp_type_like_c && requires(T v, double vd) { + // mandatory arithmetic operations + { v + v } -> std::same_as; + { v - v } -> std::same_as; + { v += v } -> std::same_as; + { v -= v } -> std::same_as; + + { vd + v } -> std::same_as; + { vd - v } -> std::same_as; + { v + vd } -> std::same_as; + { v - vd } -> std::same_as; + { v += vd } -> std::same_as; + { v -= vd } -> std::same_as; + + { v * vd } -> std::same_as; + { v / vd } -> std::same_as; +}; + + + +/* CELESTIAL COORDINATES EPOCH CLASS CONCEPT */ + +struct mcc_coord_epoch_interface_t { + virtual ~mcc_coord_epoch_interface_t() = default; + + static constexpr double MJD0 = 2400000.5; + + template SelfT, traits::mcc_input_char_range IR> + bool fromCharRange(this SelfT&& self, IR&& str) + { + return std::forward(self).fromCharRange(std::forward(str)); + } + + template SelfT, typename ClockT, typename DurT> + bool fromTimePoint(this SelfT&& self, std::chrono::time_point&& tp) + { + return std::forward(self).fromTimePoint(std::forward(tp)); + } + + template SelfT, typename VT> + bool fromMJD(this SelfT&& self, VT&& mjd) + requires std::is_arithmetic_v + { + return std::forward(self).fromMJD(std::forward(mjd)); + } + + template SelfT, traits::mcc_time_duration_c DT> + SelfT& operator+=(this SelfT& self, DT&& dt) + { + return std::forward(self).operator+=(std::forward
(dt)); + } + + template SelfT, traits::mcc_time_duration_c DT> + SelfT& operator-=(this SelfT& self, DT&& dt) + { + return std::forward(self).operator-=(std::forward
(dt)); + } +}; + +template +concept mcc_coord_epoch_c = std::derived_from && requires(T t1, T t2, const T t_const) { + { t_const.MJD() } -> std::convertible_to; + { t_const.UTC() } -> traits::mcc_systime_c; + { t_const.JEpoch() } -> traits::mcc_output_char_range; + + { t1 <=> t2 }; + + { T::now() } -> std::same_as; +}; + + + +/* CELESTIAL COORDINATE TRANSFORMATION ENGINE CLASS CONCEPT */ + +template +struct mcc_ccte_engine_interface_t { + virtual ~mcc_ccte_engine_interface_t() = default; + + // returns geographical site coordinates for underlying transformation calculations + template SelfT, mcc_angle_c LAT_T, mcc_angle_c LON_T> + void geoPosition(this SelfT&& self, std::pair* pos) + { + std::forward(self).geoPosition(pos); + } + + template SelfT, mcc_angle_c StT, mcc_coord_epoch_c EpT> + auto apparentSideralTime(this SelfT&& self, EpT const& ep, StT* st, bool isLocal) + { + return std::forward(self).apparentSideralTime(ep, st, isLocal); + } + + // from ICRS to observed (taking into account atmospheric refraction) coordinate transformation + template SelfT, + mcc_angle_c RA_ICRS_T, + mcc_angle_c DEC_ICRS_T, + mcc_coord_epoch_c EpT, + mcc_angle_c RA_OBS_T, + mcc_angle_c DEC_OBS_T, + mcc_angle_c HA_OBS_T, + mcc_angle_c AZ_T, + mcc_angle_c ZD_T> + RetT icrsToObs(this SelfT&& self, + RA_ICRS_T const& ra_icrs, + DEC_ICRS_T const& dec_icrs, + EpT const& ep, + RA_OBS_T* ra, + DEC_OBS_T* dec, + HA_OBS_T* ha, + AZ_T* az, + ZD_T* zd) + { + return std::forward(self).icrsToObs(ra_icrs, dec_icrs, ep, ra, dec, ha, az, zd); + } + + + // from ICRS to apparent (in vacuo) coordinate transformation + template SelfT, + mcc_angle_c RA_ICRS_T, + mcc_angle_c DEC_ICRS_T, + mcc_coord_epoch_c EpT, + mcc_angle_c RA_APP_T, + mcc_angle_c DEC_APP_T, + mcc_angle_c HA_APP_T, + mcc_angle_c AZ_T, + mcc_angle_c ZD_T> + RetT icrsToApp(this SelfT&& self, + RA_ICRS_T const& ra_icrs, + DEC_ICRS_T const& dec_icrs, + EpT const& ep, + RA_APP_T* ra, + DEC_APP_T* dec, + HA_APP_T* ha, + AZ_T* az, + ZD_T* zd) + { + return std::forward(self).icrsToApp(ra_icrs, dec_icrs, ep, ra, dec, ha, az, zd); + } + + + // from observed (taking into account atmospheric refraction) to ICRS coordinate transformation + template SelfT, + mcc_coord_epoch_c EpT, + mcc_angle_c CO_LON_T, + mcc_angle_c CO_LAT_T, + mcc_angle_c RA_ICRS_T, + mcc_angle_c DEC_ICRS_T> + RetT obsToICRS(this SelfT&& self, + impl::MccCoordPairKind obs_type, + EpT const& epoch, + CO_LON_T const& co_lon, + CO_LAT_T const& co_lat, + RA_ICRS_T* ra_icrs, + DEC_ICRS_T* dec_icrs) + { + return std::forward(self).obsToICRS(epoch, obs_type, co_lon, co_lat, ra_icrs, dec_icrs); + } + + + // from apparent (in vacuo) to ICRS coordinate transformation + template SelfT, + mcc_coord_epoch_c EpT, + mcc_angle_c CO_LON_T, + mcc_angle_c CO_LAT_T, + mcc_angle_c RA_ICRS_T, + mcc_angle_c DEC_ICRS_T> + RetT appToICRS(this SelfT&& self, + impl::MccCoordPairKind app_type, + EpT const& epoch, + CO_LON_T const& co_lon, + CO_LAT_T const& co_lat, + RA_ICRS_T* ra_icrs, + DEC_ICRS_T* dec_icrs) + { + return std::forward(self).appToICRS(epoch, app_type, co_lon, co_lat, ra_icrs, dec_icrs); + } + + // compute equation of origins EO = ERA-GAST + template SelfT, mcc_coord_epoch_c EpT, mcc_angle_c EO_T> + RetT equationOrigins(this SelfT&& self, EpT const& epoch, EO_T* eo) + { + return std::forward(self).equationOrigins(epoch, eo); + } + + + // compute refraction correction from observed zenithal distance + // (Zapp = Zobs + dZ) + template SelfT, mcc_angle_c ZD_OBS_T, mcc_angle_c DZ_T> + RetT refractionCorrection(this SelfT&& self, ZD_OBS_T const& zd_obs, DZ_T* dZ) + { + return std::forward(self).refractionCorrection(zd_obs, dZ); + } + + + // compute refraction correction from apparent (in vacuo) zenithal distance + // (Zobs = Zapp - dZ) + template SelfT, mcc_angle_c ZD_APP_T, mcc_angle_c DZ_T> + RetT refractionInverseCorrection(this SelfT&& self, ZD_APP_T const& zd_app, DZ_T* dZ) + { + return std::forward(self).refractionInverseCorrection(zd_app, dZ); + } +}; + + +template +concept mcc_ccte_c = std::derived_from> && requires { + // error type + requires mcc_error_c; + + // static const variable with name of CCTE + requires std::formattable && std::is_const_v; +}; + + + +/* COORDINATES PAIR CLASS CONCEPT */ + +struct mcc_coord_pair_interface_t { + virtual ~mcc_coord_pair_interface_t() = default; + + template SelfT, mcc_coord_epoch_c EpT> + auto setEpoch(this SelfT&& self, EpT const& ep) + { + return std::forward(self).setEpoch(ep); + } +}; + +template +concept mcc_coord_pair_c = std::derived_from && requires(T t) { + // the 'T' class must contain static constexpr member of 'pairKind' of some type + // (usually just a enum: see mcc_coordinate.h for an example of the implementation) + []() { + [[maybe_unused]] static constexpr auto val = T::pairKind; + }(); // to ensure 'pairKind' can be used in compile-time context + + requires mcc_angle_c; // co-longitude coordinate type + requires mcc_angle_c; // co-latitude coordinate type + + // std::constructible_from; + + { t.x() } -> std::same_as; + { t.y() } -> std::same_as; + + { t.setX(std::declval()) }; + { t.setY(std::declval()) }; +}; + + + +/* SKY POINT CLASS CONCEPT */ + + +struct mcc_skypoint_interface_t { + virtual ~mcc_skypoint_interface_t() = default; + + template SelfT, mcc_coord_pair_c PT> + auto from(this SelfT&& self, PT&& cpair) + { + return std::forward(self).from(std::forward(cpair)); + } + + template SelfT, mcc_coord_pair_c PT> + auto operator=(this SelfT&& self, PT&& cpair) + { + return std::forward(self).operator=(std::forward(cpair)); + } + + + template SelfT, mcc_coord_pair_c PT, mcc_coord_pair_c... PTs> + auto to(this SelfT&& self, PT& cpair, PTs&... cpairs) + { + return std::forward(self).to(cpair, cpairs...); + } + + template SelfT, mcc_coord_pair_c PT> + operator PT(this SelfT&& self) + { + return std::forward(self).operator PT(); + } + + // mandatory specialization conversional operator to + // get geographic coordinates used in underlying transformation calculations + // (it are geographic site coordinates mandatory used in celestial coordinate transformation engine + // of any implementation of skypoint class) + template SelfT, mcc_coord_pair_c PT> + requires(PT::pairKind == impl::MccCoordPairKind::COORDS_KIND_LONLAT) + operator PT(this SelfT&& self) + { + return std::forward(self).operator PT(); + } + + + // return coordinates pair at same epoch as 'this' sky point + template SelfT, mcc_coord_pair_c PT, mcc_coord_pair_c... PTs> + auto toAtSameEpoch(this SelfT&& self, PT& cpair, PTs&... cpairs) + { + return std::forward(self).to(cpair, cpairs...); + } + + + // Refraction correction for given celestial point. + // It is assumed that for the apparent (in vacuo) and ICRS kinds of coordinates this correction is 0! + // The returned refraction correction must be calculated as the correction applied to observed (affected by + // refraction) zenithal distance to compute apparent (in vacuo) one, i.e., Z_app = Z_obs + refr_corr + template SelfT> + auto refractCorrection(this SelfT&& self, mcc_angle_c auto* dZ) + { + return std::forward(self).refractCorrection(dZ); + } + + // As above but the returned correction must be calculated as the correction applied to apparent (in vacuo) + // zenithal distance to compute observed (affected by refraction) one, i.e., Z_obs = Z_app - refr_corr. + // It is assumed that for the observed and ICRS kinds of coordinates this correction is 0! + template SelfT> + auto refractInverseCorrection(this SelfT&& self, mcc_angle_c auto* dZ) + { + return std::forward(self).refractInverseCorrection(dZ); + } + + // returns apparent sideral time (Greenwich) for the epoch of the celestial point + template SelfT> + auto appSideralTime(this SelfT&& self, mcc_angle_c auto* st) + { + return std::forward(self).appSideralTime(st); + } + + // returns equation of origins for the epoch of the celestial point + template SelfT> + auto EO(this SelfT&& self, mcc_angle_c auto* eo) + { + return std::forward(self).EO(eo); + } +}; + +template +concept mcc_skypoint_c = std::derived_from && requires(const T t_const) { + { t_const.epoch() } -> mcc_coord_epoch_c; + + // currently stored coordinates pair + { t_const.pairKind() } -> std::same_as; +}; + + + +/* POINTING CORRECTION MODEL CLASS CONCEPT */ + + + +// The result of PCM calculations must be at least corrections along both mount axes +template +concept mcc_pcm_result_c = requires(T t) { + requires mcc_angle_c; + requires mcc_angle_c; +}; + + +template +struct mcc_pcm_interface_t { + virtual ~mcc_pcm_interface_t() = default; + + template SelfT, mcc_coord_pair_c HW_COORD_T> + RetT computePCM(this SelfT&& self, + HW_COORD_T const& hw_coord, + mcc_pcm_result_c auto* result, + mcc_skypoint_c auto* obs_pt) + { + return std::forward(self).computePCM(hw_coord, result, obs_pt); + } + + + template SelfT, mcc_coord_pair_c HW_COORD_T> + RetT computeInversePCM(this SelfT&& self, + mcc_skypoint_c auto const& obs_pt, + mcc_pcm_result_c auto* inv_result, + HW_COORD_T* hw_coord) + { + return std::forward(self).computeInversePCM(obs_pt, inv_result, hw_coord); + } +}; + + +template +concept mcc_pcm_c = std::derived_from> && requires { + // error type + requires mcc_error_c; + + // the 'T' class must contain static constexpr member of 'MccMountType' type + requires std::same_as; + []() { + [[maybe_unused]] static constexpr MccMountType val = T::mountType; + }(); // to ensure 'mountType' can be used in compile-time context + + // static const variable with name of PCM + requires std::formattable && std::is_const_v; +}; + + + +/* MOUNT HARDWARE ABSTRACTION CLASS CONCEPT */ + + +// a type that defines at least HW_MOVE_ERROR, HW_MOVE_STOPPED, HW_MOVE_SLEWING, HW_MOVE_ADJUSTING, HW_MOVE_TRACKING +// and HW_MOVE_GUIDING compile-time constants. +// +// e.g. an implementations can be as follows: +// enum class hardware_movement_state_t: int {HW_MOVE_ERROR = -1, HW_MOVE_STOPPED = 0, HW_MOVE_SLEWING, +// HW_MOVE_ADJUSTING, HW_MOVE_TRACKING, HW_MOVE_GUIDING} +// +// struct hardware_movement_state_t { +// static constexpr uint16_t HW_MOVE_STOPPED = 0; +// static constexpr uint16_t HW_MOVE_SLEWING = 111; +// static constexpr uint16_t HW_MOVE_ADJUSTING = 222; +// static constexpr uint16_t HW_MOVE_TRACKING = 333; +// static constexpr uint16_t HW_MOVE_GUIDING = 444; +// static constexpr uint16_t HW_MOVE_ERROR = 555; +// } +template +concept mcc_hardware_movement_state_c = requires { + []() { + // // mount axes were stopped + // [[maybe_unused]] static constexpr auto v0 = T::HW_MOVE_STOPPED; + + // // hardware was asked for slewing (move to given celestial point) + // [[maybe_unused]] static constexpr auto v1 = T::HW_MOVE_SLEWING; + + // // hardware was asked for adjusting after slewing + // // (adjusting actual mount position to align with target celestial point at the end of slewing process) + // [[maybe_unused]] static constexpr auto v2 = T::HW_MOVE_ADJUSTING; + + // // hardware was asked for tracking (track target celestial point) + // [[maybe_unused]] static constexpr auto v3 = T::HW_MOVE_TRACKING; + + // // hardware was asked for guiding + // // (small corrections to align actual mount position with target celestial point) + // [[maybe_unused]] static constexpr auto v4 = T::HW_MOVE_GUIDING; + + // // to detect possible hardware error + // [[maybe_unused]] static constexpr auto v5 = T::HW_MOVE_ERROR; + + [[maybe_unused]] static constexpr std::array arr{ + // mount hardware was asked to stop + T::HW_MOVE_STOPPING, + + // mount axes were stopped + T::HW_MOVE_STOPPED, + + // move to given celestial point + T::HW_MOVE_SLEWING, + + // adjusting after slewing + T::HW_MOVE_ADJUSTING, + + // tracking (track target celestial point) + T::HW_MOVE_TRACKING, + + // guiding (small corrections to align actual mount position with target celestial point) + T::HW_MOVE_GUIDING, + + // to detect possible hardware error + T::HW_MOVE_ERROR}; + }(); +}; + + +template +concept mcc_hardware_state_c = requires(T state) { + // encoder co-longitude and co-latiitude positions, as well as its measurement time point + // the given constrains on coordinate pair kind can be used to deduce mount type + requires mcc_coord_pair_c && + (decltype(state.XY)::pairKind == impl::MccCoordPairKind::COORDS_KIND_GENERIC || + decltype(state.XY)::pairKind == impl::MccCoordPairKind::COORDS_KIND_XY); + + // co-longitude and co-latiitude axis angular speeds, as well as its measurement/computation time point + requires mcc_coord_pair_c && + (decltype(state.speedXY)::pairKind == impl::MccCoordPairKind::COORDS_KIND_GENERIC || + decltype(state.speedXY)::pairKind == impl::MccCoordPairKind::COORDS_KIND_XY); + + + requires mcc_hardware_movement_state_c; +}; + + +template +concept mcc_hardware_c = requires(T t) { + // error type + requires mcc_error_c; + + // static const variable with name of hardware + requires std::formattable && std::is_const_v; + + // a type that defines at least HW_MOVE_ERROR, HW_MOVE_STOPPING, HW_MOVE_STOPPED, HW_MOVE_SLEWING, + // HW_MOVE_ADJUSTING, HW_MOVE_TRACKING and HW_MOVE_GUIDING compile-time constants. The main purpose of this type is + // a possible tunning of hardware hardwareSetState-related commands and detect the stop and error states from + // hardware + // + // e.g. an implementations can be as follows: + // enum class hardware_movement_state_t: int {HW_MOVE_ERROR = -1, HW_MOVE_STOPPED = 0, HW_MOVE_STOPPING, + // HW_MOVE_SLEWING, HW_MOVE_ADJUSTING, HW_MOVE_TRACKING, HW_MOVE_GUIDING} + // + // struct hardware_movement_state_t { + // static constexpr uint16_t HW_MOVE_STOPPED = 0; + // static constexpr uint16_t HW_MOVE_SLEWING = 111; + // static constexpr uint16_t HW_MOVE_ADJUSTING = 222; + // static constexpr uint16_t HW_MOVE_TRACKING = 333; + // static constexpr uint16_t HW_MOVE_GUIDING = 444; + // static constexpr uint16_t HW_MOVE_ERROR = 555; + // static constexpr uint16_t HW_MOVE_STOPPING = 666; + // } + + requires mcc_hardware_movement_state_c; + + // requires requires(typename T::hardware_movement_state_t type) { + // []() { + // // mount axes were stopped + // static constexpr auto v0 = T::hardware_movement_state_t::HW_MOVE_STOPPED; + + // // hardware was asked for slewing (move to given celestial point) + // static constexpr auto v1 = T::hardware_movement_state_t::HW_MOVE_SLEWING; + + // // hardware was asked for adjusting after slewing + // // (adjusting actual mount position to align with target celestial point at the end of slewing process) + // static constexpr auto v2 = T::hardware_movement_state_t::HW_MOVE_ADJUSTING; + + // // hardware was asked for tracking (track target celestial point) + // static constexpr auto v3 = T::hardware_movement_state_t::HW_MOVE_TRACKING; + + // // hardware was asked for guiding + // // (small corrections to align actual mount position with target celestial point) + // static constexpr auto v4 = T::hardware_movement_state_t::HW_MOVE_GUIDING; + + // // to detect possible hardware error + // static constexpr auto v5 = T::hardware_movement_state_t::HW_MOVE_ERROR; + // }(); + // }; + + requires mcc_hardware_state_c && requires(typename T::hardware_state_t state) { + requires std::same_as; + }; + + // requires requires(typename T::hardware_state_t state) { + // // encoder co-longitude and co-latiitude positions, as well as its measurement time point + // // the given constrains on coordinate pair kind can be used to deduce mount type + // requires mcc_coord_pair_c && + // ( // for equathorial mount: + // decltype(state.XY)::pairKind == impl::MccCoordPairKind::COORDS_KIND_HADEC_OBS || + // // for alt-azimuthal mount: + // decltype(state.XY)::pairKind == impl::MccCoordPairKind::COORDS_KIND_AZALT || + // decltype(state.XY)::pairKind == impl::MccCoordPairKind::COORDS_KIND_AZZD); + + // // co-longitude and co-latiitude axis angular speeds, as well as its measurement/computation time point + // requires mcc_coord_pair_c && + // (decltype(state.XY)::pairKind == impl::MccCoordPairKind::COORDS_KIND_GENERIC || + // decltype(state.XY)::pairKind == impl::MccCoordPairKind::COORDS_KIND_XY); + + + // requires std::same_as; + // }; + + + // set hardware state: + { t.hardwareSetState(std::declval()) } -> std::same_as; + + // get current state + { t.hardwareGetState(std::declval()) } -> std::same_as; + + // { t.hardwareStop() } -> std::same_as; // stop any moving + { t.hardwareInit() } -> std::same_as; // initialize hardware +}; + + +/* MOUNT TELEMETRY DATA CLASS CONCEPT */ + +template +concept mcc_telemetry_data_c = requires(T t) { + // target celestial point (position on sky where mount must be slewed) + requires mcc_skypoint_c; + + // mount current celestial position + requires mcc_skypoint_c; + + // hardware state + requires mcc_hardware_state_c; + + // corrections to transform hardware encoder coordinates to observed celestial ones + requires mcc_pcm_result_c; + + // requires mcc_angle_c; // PCM correction along X-axis + // requires mcc_angle_c; // PCM correction along Y-axis + + // // atmospheric refraction correction for current zenithal distance + // requires mcc_angle_c; + + + // // current local apparent sideral time + // requires mcc_angle_c; + + // // equation of the origins (ERA-GST) + // requires mcc_angle_c; + + // // target celestial point + // { t.targetPos() } -> mcc_skypoint_c; + + // // mount current celestial position + // { t.mountPos() } -> mcc_skypoint_c; + + // // hardware state + // { t.hwState() } -> mcc_hardware_c; + + // // corrections to transform hardware encoder coordinates to observed celestial ones + // { t.pcmData() } -> mcc_pcm_result_c; + + // // // atmospheric refraction correction for current mount zenithal distance + // // { t.refractionCorr() } -> mcc_angle_c; + + // // current local apparent sideral time + // { t.LST() } -> mcc_angle_c; + + // // equation of the origins (ERA-GST) + // { t.EO() } -> mcc_angle_c; +}; + + +/* MOUNT TELEMETRY CLASS CONCEPT */ + +template +struct mcc_telemetry_interface_t { + virtual ~mcc_telemetry_interface_t() = default; + + // set target position + template SelfT> + RetT setTarget(this SelfT&& self, mcc_skypoint_c auto const& pt) + { + return std::forward(self).setTarget(pt); + } +}; + +template +concept mcc_telemetry_c = std::derived_from> && requires(T t) { + // error type + requires mcc_error_c; + + // telemetry data type definition + requires mcc_telemetry_data_c; + + // get telemetry data + { t.telemetryData(std::declval()) } -> std::same_as; +}; + + + +/* PROHIBITED ZONE CLASS CONCEPT */ + + +enum class MccProhibitedZonePolicy : int { + PZ_POLICY_STOP, // stop mount near the zone + PZ_POLICY_FLIP // flip mount, e.g., near the meridian, near HA-axis encoder limit switch +}; + + +template +struct mcc_pzone_interface_t { + virtual ~mcc_pzone_interface_t() = default; + + template SelfT> + RetT inPZone(this SelfT&& self, mcc_skypoint_c auto const& coords, bool* result) + { + return std::forward(self).inPZone(coords, result); + } + + template SelfT> + RetT timeToPZone(this SelfT&& self, mcc_skypoint_c auto const& coords, traits::mcc_time_duration_c auto* res_time) + { + return std::forward(self).timeToPZone(coords, res_time); + } + + template SelfT> + RetT timeFromPZone(this SelfT&& self, mcc_skypoint_c auto const& coords, traits::mcc_time_duration_c auto* res_time) + { + return std::forward(self).timeFromPZone(coords, res_time); + } +}; + + +template +concept mcc_pzone_c = std::derived_from> && requires(T t) { + // error type + requires mcc_error_c; + + // static constant member with prohibitted zone name + requires std::formattable && std::is_const_v; + + // the 'T' class must contain static constexpr member of 'MccProhibitedZonePolicy' type + requires std::same_as; + []() { + [[maybe_unused]] static constexpr MccProhibitedZonePolicy val = T::pzPolicy; + }(); // to ensure 'pzPolicy' can be used in compile-time context +}; + + +/* PROHIBITED ZONES CONTAINER CLASS CONCEPT */ + +template +struct mcc_pzone_container_interface_t { + virtual ~mcc_pzone_container_interface_t() = default; + + + template SelfT> + size_t addPZone(this SelfT&& self, mcc_pzone_c auto zone) + { + return std::forward(self).addPZone(std::move(zone)); + } + + + template SelfT> + void clearPZones(this SelfT&& self) + { + return std::forward(self).clearPZones(); + } + + + template SelfT> + size_t sizePZones(this SelfT&& self) + { + return std::forward(self).sizePZones(); + } + + + template SelfT> + RetT inPZone(this SelfT&& self, + mcc_skypoint_c auto const& coords, + bool* at_least_one, + std::ranges::output_range auto* result) + { + return std::forward(self).inPZone(coords, at_least_one, result); + } + + + template SelfT, traits::mcc_time_duration_c DT> + RetT timeToPZone(this SelfT&& self, mcc_skypoint_c auto const& coords, std::ranges::output_range
auto* res_time) + { + return std::forward(self).timeToPZone(coords, res_time); + } + + template SelfT, traits::mcc_time_duration_c DT> + RetT timeFromPZone(this SelfT&& self, + mcc_skypoint_c auto const& coords, + std::ranges::output_range
auto* res_time) + { + return std::forward(self).timeFromPZone(coords, res_time); + } +}; + + +template +concept mcc_pzone_container_c = std::derived_from> && requires { + // error type + requires mcc_error_c; +}; + + + +/* A CONCEPT FOR MOUNT MOVEMENT CONTROLS CLASS */ + + +template +concept mcc_movement_controls_c = requires(T t) { + // error type + requires mcc_error_c; + + // movement parameters holder type + typename T::movement_params_t; + + // argument of the method: + // true - slew and stop + // false - slew and track + { t.slewToTarget(std::declval()) } -> std::same_as; + + { t.trackTarget() } -> std::same_as; + + { t.stopMount() } -> std::same_as; + + { t.setMovementParams(std::declval()) } -> std::same_as; + + { t.getMovementParams() } -> std::same_as; +}; + + + +/* GENERIC MOUNT CLASS CONCEPT */ + + +// minimal set of the mount status constants +template +concept mcc_mount_status_c = requires { + []() { + [[maybe_unused]] static constexpr std::array arr = { + T::MOUNT_STATUS_ERROR, T::MOUNT_STATUS_IDLE, T::MOUNT_STATUS_INITIALIZATION, + T::MOUNT_STATUS_ERROR, T::MOUNT_STATUS_STOPPED, T::MOUNT_STATUS_SLEWING, + T::MOUNT_STATUS_ADJUSTING, T::MOUNT_STATUS_GUIDING, T::MOUNT_STATUS_TRACKING}; + }; // to ensure mount status is compile-time constants +}; + + + +template +concept mcc_generic_mount_c = + mcc_logger_c && mcc_pzone_container_c && mcc_telemetry_c && mcc_movement_controls_c && requires(T t) { + // error type + requires mcc_error_c; + + requires mcc_mount_status_c; + + { t.initMount() } -> std::same_as; + + { t.mountStatus() } -> std::same_as; + }; + + +} // namespace mcc diff --git a/mcc_constants.h b/mcc_constants.h new file mode 100644 index 0000000..192aaf2 --- /dev/null +++ b/mcc_constants.h @@ -0,0 +1,35 @@ +#pragma once + + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * LIBRARY-WIDE CONSTANTS * + * * + ****************************************************************************************/ + + +#include + +#include "mcc_traits.h" + +namespace mcc +{ + +constexpr double MCC_HALF_PI = std::numbers::pi / 2.0; +constexpr double MCC_TWO_PI = std::numbers::pi * 2.0; + +static constexpr double MCC_SIDERAL_TO_UT1_RATIO = 1.002737909350795; // sideral/UT1 + + +// a value to represent of infinite time duration according to type of duration representation +template +static constexpr DT MCC_INFINITE_DURATION_V = + std::floating_point ? DT{std::numeric_limits::infinity()} + : DT{std::numeric_limits::max()}; + + + +} // namespace mcc diff --git a/mcc_coordinate.h b/mcc_coordinate.h new file mode 100644 index 0000000..bed101d --- /dev/null +++ b/mcc_coordinate.h @@ -0,0 +1,910 @@ +#pragma once + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * IMPLEMENTATION OF CELESTIAL COORDINATES * + * * + ****************************************************************************************/ + + + +// #include "mcc_angle.h" +#include "mcc_ccte_erfa.h" +#include "mcc_concepts.h" +#include "mcc_epoch.h" + +namespace mcc::impl +{ + + +/* CLASSES TO REPRESENT COORDINATES PAIR */ + +template +class MccCoordPair : public mcc_coord_pair_interface_t +{ +public: + typedef CO_LON_T x_t; + typedef CO_LAT_T y_t; + + static constexpr MccCoordPairKind pairKind = + !(std::derived_from || + std::derived_from) // unknown type (possibly just double or float) + ? MccCoordPairKind::COORDS_KIND_GENERIC + : (std::same_as || std::same_as) // one of the types is MccAngle + ? MccCoordPairKind::COORDS_KIND_GENERIC + // ICRS RA and DEC + : (std::same_as && std::same_as) + ? MccCoordPairKind::COORDS_KIND_RADEC_ICRS + // apparent RA and DEC + : (std::same_as && std::same_as) + ? MccCoordPairKind::COORDS_KIND_RADEC_APP + // observed RA and DEC + : (std::same_as && std::same_as) + ? MccCoordPairKind::COORDS_KIND_RADEC_OBS + // apparent HA and DEC + : (std::same_as && std::same_as) + ? MccCoordPairKind::COORDS_KIND_HADEC_APP + // observed HA and DEC + : (std::same_as && std::same_as) + ? MccCoordPairKind::COORDS_KIND_HADEC_OBS + // apparent AZ and ZD + : (std::same_as && std::same_as) + ? MccCoordPairKind::COORDS_KIND_AZZD + // apparent AZ and ALT + : (std::same_as && std::same_as) + ? MccCoordPairKind::COORDS_KIND_AZALT + // general purpose X and Y + : (std::same_as && std::same_as) + ? MccCoordPairKind::COORDS_KIND_XY + // geographical longitude and latitude + : (std::same_as && std::same_as) + ? MccCoordPairKind::COORDS_KIND_LONLAT + : MccCoordPairKind::COORDS_KIND_UNKNOWN; + + MccCoordPair() : _x(0.0), _y(0.0), _epoch(MccCelestialCoordEpoch::now()) {} + + template + MccCoordPair(CO_LON_T const& x, CO_LAT_T const& y, EpT const& epoch = EpT::now()) : _x(x), _y(y), _epoch(epoch) + { + } + + MccCoordPair(const MccCoordPair&) = default; + MccCoordPair(MccCoordPair&&) = default; + + MccCoordPair& operator=(const MccCoordPair&) = default; + MccCoordPair& operator=(MccCoordPair&&) = default; + + template + requires(T::pairKind == pairKind || T::pairKind == MccCoordPairKind::COORDS_KIND_GENERIC || + T::pairKind == MccCoordPairKind::COORDS_KIND_XY) + MccCoordPair(const T& other) + { + setX((double)other.x()); + setY((double)other.y()); + setEpoch(other.epoch()); + } + + + template + requires(T::pairKind == pairKind || T::pairKind == MccCoordPairKind::COORDS_KIND_GENERIC || + T::pairKind == MccCoordPairKind::COORDS_KIND_XY) + MccCoordPair(T&& other) + { + setX((double)other.x()); + setY((double)other.y()); + setEpoch(other.epoch()); + } + + + template + requires(T::pairKind == pairKind || T::pairKind == MccCoordPairKind::COORDS_KIND_GENERIC || + T::pairKind == MccCoordPairKind::COORDS_KIND_XY) + MccCoordPair& operator=(const T& other) + { + setX((double)other.x()); + setY((double)other.y()); + setEpoch(other.epoch()); + } + + + template + requires(T::pairKind == pairKind || T::pairKind == MccCoordPairKind::COORDS_KIND_GENERIC || + T::pairKind == MccCoordPairKind::COORDS_KIND_XY) + MccCoordPair& operator=(T&& other) + { + setX((double)other.x()); + setY((double)other.y()); + setEpoch(other.epoch()); + } + + + virtual ~MccCoordPair() = default; + + CO_LON_T x() const + { + return _x; + } + + CO_LAT_T y() const + { + return _y; + } + + + MccCelestialCoordEpoch epoch() const + { + return _epoch; + } + + template + EpT epoch() const + { + return _epoch; + } + + + double MJD() const + { + return _epoch.MJD(); + } + + // for something like: + // auto [ra, dec, epoch] = coord_pair; + operator std::tuple() const + { + return {_x, _y, _epoch}; + } + + void setX(const CO_LON_T& x) + { + _x = x; + } + + void setY(const CO_LAT_T& y) + { + _y = y; + } + + void setEpoch(mcc_coord_epoch_c auto const& ep) + { + _epoch = ep; + } + +protected: + CO_LON_T _x; + CO_LAT_T _y; + + MccCelestialCoordEpoch _epoch; +}; + + +static_assert(mcc_coord_pair_c>, ""); + + +/* PREDEFINED COORDINATES PAIR TYPES */ + + + +struct MccSkyRADEC_ICRS : MccCoordPair { + // re-implement constructors to keep the epoch equal to J2000.0 + + MccSkyRADEC_ICRS() : MccCoordPair(0.0, 0.0, MccCelestialCoordEpoch{}) {} + + MccSkyRADEC_ICRS(MccAngleRA_ICRS const& x, MccAngleDEC_ICRS const& y) + : MccCoordPair((double)x, (double)y, MccCelestialCoordEpoch{}) + { + } + + // ignore epoch setting (it is always J2000.0) + void setEpoch(mcc_coord_epoch_c auto const&) + { + static_assert(false, "CANNOT SET EPOCH FOR ICRS-KIND COORDINATE PAIR!!!"); + } +}; + +using MccSkyRADEC_APP = MccCoordPair; + +using MccSkyRADEC_OBS = MccCoordPair; + +using MccSkyHADEC_APP = MccCoordPair; + +using MccSkyHADEC_OBS = MccCoordPair; + +// using MccSkyAZZD = MccCoordPair; +struct MccSkyAZZD : MccCoordPair { + using MccCoordPair::MccCoordPair; + + template + requires(AZALT_PAIR_T::pairKind == MccCoordPairKind::COORDS_KIND_AZALT) + MccSkyAZZD(AZALT_PAIR_T const& azalt) : MccSkyAZZD() + { + setX((double)azalt.x()); + // setY(std::numbers::pi / 2.0 - (double)azalt.x()); + setY(MCC_HALF_PI - (double)azalt.x()); + setEpoch(azalt.epoch()); + } + + template + requires(AZALT_PAIR_T::pairKind == MccCoordPairKind::COORDS_KIND_AZALT) + MccSkyAZZD(AZALT_PAIR_T&& azalt) : MccSkyAZZD() + { + setX((double)azalt.x()); + // setY(std::numbers::pi / 2.0 - (double)azalt.x()); + setY(MCC_HALF_PI - (double)azalt.x()); + setEpoch(azalt.epoch()); + } + + template + requires(AZALT_PAIR_T::pairKind == MccCoordPairKind::COORDS_KIND_AZALT) + MccSkyAZZD& operator=(AZALT_PAIR_T const& azalt) + { + setX((double)azalt.x()); + // setY(std::numbers::pi / 2.0 - (double)azalt.x()); + setY(MCC_HALF_PI - (double)azalt.x()); + setEpoch(azalt.epoch()); + + return *this; + } + + template + requires(AZALT_PAIR_T::pairKind == MccCoordPairKind::COORDS_KIND_AZALT) + MccSkyAZZD& operator=(AZALT_PAIR_T&& azalt) + { + setX((double)azalt.x()); + // setY(std::numbers::pi / 2.0 - (double)azalt.x()); + setY(MCC_HALF_PI - (double)azalt.x()); + setEpoch(azalt.epoch()); + + return *this; + } +}; + +// using MccSkyAZALT = MccCoordPair; +struct MccSkyAZALT : MccCoordPair { + using MccCoordPair::MccCoordPair; + + template + requires(AZZD_PAIR_T::pairKind == MccCoordPairKind::COORDS_KIND_AZZD) + MccSkyAZALT(AZZD_PAIR_T const& azzd) : MccSkyAZALT() + { + setX((double)azzd.x()); + // setY(std::numbers::pi / 2.0 - (double)azzd.x()); + setY(MCC_HALF_PI - (double)azzd.x()); + setEpoch(azzd.epoch()); + } + + template + requires(AZZD_PAIR_T::pairKind == MccCoordPairKind::COORDS_KIND_AZZD) + MccSkyAZALT(AZZD_PAIR_T&& azzd) : MccSkyAZALT() + { + setX((double)azzd.x()); + // setY(std::numbers::pi / 2.0 - (double)azzd.x()); + setY(MCC_HALF_PI - (double)azzd.x()); + setEpoch(azzd.epoch()); + } + + template + requires(AZZD_PAIR_T::pairKind == MccCoordPairKind::COORDS_KIND_AZZD) + MccSkyAZALT& operator=(AZZD_PAIR_T const& azzd) + { + setX((double)azzd.x()); + // setY(std::numbers::pi / 2.0 - (double)azzd.x()); + setY(MCC_HALF_PI - (double)azzd.x()); + setEpoch(azzd.epoch()); + + return *this; + } + + template + requires(AZZD_PAIR_T::pairKind == MccCoordPairKind::COORDS_KIND_AZZD) + MccSkyAZALT& operator=(AZZD_PAIR_T&& azzd) + { + setX((double)azzd.x()); + // setY(std::numbers::pi / 2.0 - (double)azzd.x()); + setY(MCC_HALF_PI - (double)azzd.x()); + setEpoch(azzd.epoch()); + + return *this; + } +}; + + +using MccGenXY = MccCoordPair; + +using MccGeoLONLAT = MccCoordPair; + + +static MccSkyHADEC_APP hadec = MccGenXY{}; +static MccSkyAZALT azalt{MccSkyAZZD{1.0, 1.1}}; + + +/* MCC-LIBRARY DEFAULT GENERIC SKY POINT CLASS IMPLEMENTATION */ + + + +template +class MccGenericSkyPoint : public mcc_skypoint_interface_t +{ +public: + typedef CCTE_T ccte_t; + + static constexpr double MJD0 = 2400000.5; + + inline static CCTE_T cctEngine{}; // celestial coordinates transformation engine + + using error_t = typename CCTE_T::error_t; + + MccGenericSkyPoint() {} + + template + MccGenericSkyPoint(const PT& coord_pair) : MccGenericSkyPoint() + { + auto self = from(coord_pair); + } + + MccGenericSkyPoint(const MccGenericSkyPoint&) = default; + MccGenericSkyPoint(MccGenericSkyPoint&&) = default; + + MccGenericSkyPoint& operator=(const MccGenericSkyPoint&) = default; + MccGenericSkyPoint& operator=(MccGenericSkyPoint&&) = default; + + + MccGenericSkyPoint(mcc_skypoint_c auto const& other) + { + fromOtherSkyPoint(other); + } + + MccGenericSkyPoint(mcc_skypoint_c auto&& other) + { + fromOtherSkyPoint(other); + } + + + MccGenericSkyPoint& operator=(mcc_skypoint_c auto const& other) + { + fromOtherSkyPoint(other); + + return *this; + } + + MccGenericSkyPoint& operator=(mcc_skypoint_c auto&& other) + { + fromOtherSkyPoint(other); + + return *this; + } + + + virtual ~MccGenericSkyPoint() = default; + + MccCoordPairKind pairKind() const + { + return _pairKind; + } + + MccCelestialCoordEpoch epoch() const + { + return _epoch; + } + + template + MccGenericSkyPoint& from(const PT& coord_pair) + { + _x = coord_pair.x(); + _y = coord_pair.y(); + + _pairKind = PT::pairKind; + + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_RADEC_ICRS) { + _epoch = MccCelestialCoordEpoch(); // J2000.0 + } else { + _epoch.fromMJD(coord_pair.MJD()); + } + + return *this; + } + + MccGenericSkyPoint& operator=(mcc_coord_pair_c auto const& coord_pair) + { + return from(coord_pair); + } + + + template + error_t to(PT& cpair, PTs&... cpairs) const + { + auto err = toHelper(cpair); + if (err) { + return err; + } + + if constexpr (sizeof...(PTs)) { + err = to(cpairs...); + if (err) { + return err; + } + } + + // according to mcc_error_c concept (see mcc_concepts.h) + // default-constructed mcc_error_c-like class must be assumed as + // non-error state + return error_t{}; + } + + + template + operator PT() + { + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_LONLAT) { // returns geographic site coordinates + std::pair pos; + cctEngine.geoPosition(&pos); + + return MccGeoLONLAT(pos.second, pos.first); + } + + + PT res; + to(res); + + return res; + } + + + template + error_t toAtSameEpoch(PT& cpair, PTs&... cpairs) const + { + if constexpr (PT::pairKind != MccCoordPairKind::COORDS_KIND_RADEC_ICRS) { + cpair.setEpoch(_epoch); + } + auto err = toHelper(cpair); + if (err) { + return err; + } + + if constexpr (sizeof...(PTs)) { + err = toAtSameEpoch(cpairs...); + if (err) { + return err; + } + } + + // according to mcc_error_c concept (see mcc_concepts.h) + // default-constructed mcc_error_c-like class must be assumed as + // non-error state + return error_t{}; + } + + + error_t refractCorrection(mcc_angle_c auto* dZ) const + { + if (mcc_is_obs_coordpair(_pairKind)) { + if (_pairKind == MccCoordPairKind::COORDS_KIND_AZZD) { + return cctEngine.refractionCorrection(_y, dZ); + } else if (_pairKind == MccCoordPairKind::COORDS_KIND_AZALT) { + return cctEngine.refractionCorrection(MCC_HALF_PI - _y, dZ); + } else { + MccSkyAZZD azzd; + auto err = toAtSameEpoch(azzd); + if (!err) { + err = cctEngine.refractionCorrection(azzd.y(), dZ); + } + + return err; + } + } else { + if (dZ) { + *dZ = 0.0; + } + + return {}; + } + } + + + error_t refractInverseCorrection(mcc_angle_c auto* dZ) const + { + double phi = cctEngine.getStateERFA().lat; + double ha = _x, dec = _y; + + if (mcc_is_app_coordpair(_pairKind)) { + double az, alt; + + if (_pairKind == MccCoordPairKind::COORDS_KIND_RADEC_APP) { + double eo, lst; + + auto ccte_err = cctEngine.equationOrigins(_epoch, &eo); + if (ccte_err) { + return ccte_err; + } + + ccte_err = cctEngine.apparentSideralTime(_epoch, &lst, true); + if (ccte_err) { + return ccte_err; + } + + // from RA to HA + ha = lst + eo - _x; + } + + hadec2azalt(ha, dec, phi, &az, &alt); + + return cctEngine.refractionInverseCorrection(MCC_HALF_PI - alt, dZ); + } else { + if (dZ) { + *dZ = 0.0; + } + + return {}; + } + } + + + error_t appSideralTime(mcc_angle_c auto* st) const + { + // return Greenwich apparent sideral time since epoch is UTC + return cctEngine.apparentSideralTime(_epoch, st, false); + } + + + error_t EO(mcc_angle_c auto* eo) + { + return cctEngine.equationOrigins(_epoch, eo); + } + +protected: + double _x{0.0}, _y{0.0}; + MccCoordPairKind _pairKind{MccCoordPairKind::COORDS_KIND_RADEC_ICRS}; + MccCelestialCoordEpoch _epoch{}; // J2000.0 + + template + void fromOtherSkyPoint(T&& other) + { + switch (other.pairKind()) { + case MccCoordPairKind::COORDS_KIND_RADEC_ICRS: { + MccSkyRADEC_ICRS pt; + + other.to(pt); + from(pt); + } break; + case MccCoordPairKind::COORDS_KIND_RADEC_OBS: { + MccSkyRADEC_OBS pt; + pt.setEpoch(other.epoch()); + + other.to(pt); + from(pt); + } break; + case MccCoordPairKind::COORDS_KIND_RADEC_APP: { + MccSkyRADEC_APP pt; + pt.setEpoch(other.epoch()); + + other.to(pt); + from(pt); + } break; + case MccCoordPairKind::COORDS_KIND_HADEC_OBS: { + MccSkyHADEC_OBS pt; + pt.setEpoch(other.epoch()); + + other.to(pt); + from(pt); + } break; + case MccCoordPairKind::COORDS_KIND_HADEC_APP: { + MccSkyHADEC_APP pt; + pt.setEpoch(other.epoch()); + + other.to(pt); + from(pt); + } break; + case MccCoordPairKind::COORDS_KIND_AZALT: { + MccSkyAZALT pt; + pt.setEpoch(other.epoch()); + + other.to(pt); + from(pt); + } break; + case MccCoordPairKind::COORDS_KIND_AZZD: { + MccSkyAZZD pt; + pt.setEpoch(other.epoch()); + + other.to(pt); + from(pt); + } break; + default: + // error!!! + break; + } + } + + // HA, DEC to AZ, ALT (AZ from the South through the West) + void hadec2azalt(double ha, double dec, double phi, double& az, double& alt) const + { + const auto cos_phi = std::cos(phi), sin_phi = std::sin(phi); + const auto cos_dec = std::cos(dec), sin_dec = std::sin(dec); + const auto cos_ha = std::cos(ha), sin_ha = std::sin(ha); + + auto x = sin_phi * cos_dec * cos_ha - cos_phi * sin_dec; + auto y = -cos_dec * sin_ha; + auto z = cos_phi * cos_dec * cos_ha + sin_phi * sin_dec; + + auto xx = x * x, yy = y * y; + decltype(x) r; + if (xx < yy) { + r = yy * sqrt(1.0 + xx / yy); + } else { + r = xx * sqrt(1.0 + yy / xx); + } + + az = utils::isEqual(r, 0.0) ? 0.0 : std::atan2(y, x); + if (az < 0.0) { + // az += std::numbers::pi * 2.0; // to range of [0, 2*PI] + az += MCC_TWO_PI; // to range of [0, 2*PI] + } + + alt = std::atan2(z, r); + }; + + + // AZ, ALT to HA, DEC (AZ from the South through the West) + void azalt2hadec(double az, double alt, double phi, double& ha, double& dec) const + { + const auto cos_phi = std::cos(phi), sin_phi = std::sin(phi); + const auto cos_az = std::cos(az), sin_az = std::sin(az); + const auto cos_alt = std::cos(alt), sin_alt = std::sin(alt); + + auto x = sin_phi * cos_alt * cos_az + cos_phi * sin_alt; + auto y = cos_alt * sin_az; + auto z = -cos_phi * cos_alt * cos_az + sin_phi * sin_alt; + + auto xx = x * x, yy = y * y; + decltype(x) r; + if (xx < yy) { + r = yy * sqrt(1.0 + xx / yy); + } else { + r = xx * sqrt(1.0 + yy / xx); + } + + ha = utils::isEqual(r, 0.0) ? 0.0 : std::atan2(y, x); + dec = std::atan2(z, r); + }; + + + template + error_t toHelper(PT& cpair) const + { + typename CCTE_T::error_t ccte_err; + + double phi = cctEngine.getStateERFA().lat; + double ra_icrs, dec_icrs, ra, dec, ha, az, zd, alt, lst, eo; + + static_assert(PT::pairKind != MccCoordPairKind::COORDS_KIND_GENERIC, "UNSUPPORTED SKY POINT TRANSFORMATION!"); + static_assert(PT::pairKind != MccCoordPairKind::COORDS_KIND_UNKNOWN, "UNSUPPORTED SKY POINT TRANSFORMATION!"); + + + if (_pairKind == MccCoordPairKind::COORDS_KIND_RADEC_ICRS && + PT::pairKind == MccCoordPairKind::COORDS_KIND_RADEC_ICRS) { // from ICRS to ICRS - just copy and exit + cpair = PT(typename PT::x_t(_x), typename PT::y_t(_y)); + + return error_t{}; + } + + // just copy coordinates and exit + if (_pairKind == PT::pairKind && utils::isEqual(_epoch.MJD(), cpair.MJD())) { + // cpair = PT(typename PT::x_t(_x), typename PT::y_t(_y), _epoch); + cpair.setX(_x); + cpair.setY(_y); + + return error_t{}; + } + + + // if epochs are not the same then + // 1) convert stored coordinates to ICRS ones + // 2) convert from the computed ICRS coordinates to required ones + MccCoordPairKind pkind = _pairKind; + if (!utils::isEqual(_epoch.MJD(), cpair.MJD())) { // convert stored pair to ICRS one (ra_icrs, dec_icrs) + if (_pairKind != MccCoordPairKind::COORDS_KIND_RADEC_ICRS) { + pkind = MccCoordPairKind::COORDS_KIND_RADEC_ICRS; + + if (mcc_is_obs_coordpair(_pairKind)) { + ccte_err = cctEngine.obsToICRS(_pairKind, _epoch, _x, _y, &ra_icrs, &dec_icrs); + } else if (mcc_is_app_coordpair(_pairKind)) { + ccte_err = cctEngine.appToICRS(_pairKind, _epoch, _x, _y, &ra_icrs, &dec_icrs); + } else { // unsupported transformation!!! silently ignore! + return error_t{}; + } + + if (ccte_err) { + return ccte_err; + } + } else { + ra_icrs = _x; + dec_icrs = _y; + } + } + + // here, from APP or OBS to ICRS and exit + if (pkind == MccCoordPairKind::COORDS_KIND_RADEC_ICRS && + PT::pairKind == MccCoordPairKind::COORDS_KIND_RADEC_ICRS) { + cpair = PT(typename PT::x_t(ra_icrs), typename PT::y_t(dec_icrs)); + + return error_t{}; + } + + // here, the input coordinates and stored one are at the same epoch + + ccte_err = cctEngine.equationOrigins(cpair.epoch(), &eo); + if (ccte_err) { + return ccte_err; + } + + ccte_err = cctEngine.apparentSideralTime(cpair.epoch(), &lst, true); + if (ccte_err) { + return ccte_err; + } + + + if (pkind == MccCoordPairKind::COORDS_KIND_RADEC_APP || pkind == MccCoordPairKind::COORDS_KIND_RADEC_OBS) { + ra = _x; + dec = _y; + } else if (pkind == MccCoordPairKind::COORDS_KIND_HADEC_APP || + pkind == MccCoordPairKind::COORDS_KIND_HADEC_OBS) { + ha = _x; + dec = _y; + } else if (pkind == MccCoordPairKind::COORDS_KIND_AZZD) { + az = _x; + zd = _y; + } else if (pkind == MccCoordPairKind::COORDS_KIND_AZALT) { + az = _x; + alt = _y; + } + // else if (pkind == MccCoordPairKind::COORDS_KIND_RADEC_ICRS) { + // ra_icrs = _x; + // dec_icrs = _y; + // } else { // unsupported transformation!!! + // return; + // } + + // coordinate transformation lambda (possibly recursive!!!) + // "obj = this" to fix GCC compilation crash!!! + auto comp_func = [&, obj = this](this auto&& self, MccCoordPairKind cp_kind) -> error_t { + if (cp_kind == MccCoordPairKind::COORDS_KIND_RADEC_ICRS) { + if constexpr (mccIsAppCoordPairKind) { + ccte_err = cctEngine.icrsToApp(ra_icrs, dec_icrs, cpair.epoch(), &ra, &dec, &ha, &az, &zd); + } else if constexpr (mccIsObsCoordPairKind) { + ccte_err = cctEngine.icrsToObs(ra_icrs, dec_icrs, cpair.epoch(), &ra, &dec, &ha, &az, &zd); + } else { + static_assert(true, "UNSUPPORTED SKY POINT TRANSFORMATION!"); + } + + if (ccte_err) { + return ccte_err; + } + + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_RADEC_APP || + PT::pairKind == MccCoordPairKind::COORDS_KIND_RADEC_OBS) { + cpair.setX(ra); + cpair.setY(dec); + } else if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_HADEC_APP || + PT::pairKind == MccCoordPairKind::COORDS_KIND_HADEC_OBS) { + cpair.setX(ha); + cpair.setY(dec); + } else if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_AZZD) { + cpair.setX(az); + cpair.setY(zd); + } else if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_AZALT) { + cpair.setX(az); + cpair.setY(MCC_HALF_PI - zd); + } else { + static_assert(true, "UNSUPPORTED SKY POINT TRANSFORMATION!"); + } + } else if (cp_kind == MccCoordPairKind::COORDS_KIND_AZALT) { + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_AZZD) { + zd = MCC_HALF_PI - alt; + cpair.setX(az); + cpair.setY(zd); + } else { + if constexpr (mccIsAppCoordPairKind) { + // correct for refraction: alt -= dz_refr + double dZ; + ccte_err = cctEngine.refractionCorrection(MCC_HALF_PI - alt, &dZ); + if (ccte_err) { + return ccte_err; + } + + alt -= dZ; + } + + obj->azalt2hadec(az, alt, phi, ha, dec); + cpair.setY(dec); + + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_RADEC_APP) { + ra = lst + eo - ha; + cpair.setX(ra); + } else if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_RADEC_OBS) { + ra = lst + eo - ha; + cpair.setX(ra); + } else if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_HADEC_APP) { + cpair.setX(ha); + } else if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_HADEC_OBS) { + cpair.setX(ha); + } else { // unsupported transformation!!! silently ignore!!! + return error_t{}; + } + } + } else if (cp_kind == MccCoordPairKind::COORDS_KIND_AZZD) { + alt = MCC_HALF_PI - zd; + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_AZALT) { + cpair.setX(az); + cpair.setY(alt); + } else { + return self(MccCoordPairKind::COORDS_KIND_AZALT); + } + } else if (cp_kind == MccCoordPairKind::COORDS_KIND_HADEC_OBS) { + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_RADEC_OBS) { + ra = lst + eo - ha; + cpair.setX(ra); + cpair.setY(dec); + } else { + obj->hadec2azalt(ha, dec, phi, az, alt); + if constexpr (mccIsAppCoordPairKind) { // RADEC_APP, HADEC_APP + return self(MccCoordPairKind::COORDS_KIND_AZALT); + } else { // AZALT, AZZD + cpair.setX(az); + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_AZZD) { + zd = MCC_HALF_PI - alt; + cpair.setY(zd); + } else { + cpair.setY(alt); + } + } + } + } else if (cp_kind == MccCoordPairKind::COORDS_KIND_HADEC_APP) { + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_RADEC_APP) { + ra = lst + eo - ha; + cpair.setX(ra); + cpair.setY(dec); + } else { + obj->hadec2azalt(ha, dec, phi, az, alt); + if constexpr (mccIsObsCoordPairKind) { // RADEC_OBS, HADEC_OBS, AZALT, AZZD + // correct for refraction: alt += dz_refr + double dZ; + ccte_err = cctEngine.refractionInverseCorrection(MCC_HALF_PI - alt, &dZ); + alt += dZ; + return self(MccCoordPairKind::COORDS_KIND_AZALT); + } + } + } else if (cp_kind == MccCoordPairKind::COORDS_KIND_RADEC_OBS) { + ha = lst + eo - ra; + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_HADEC_OBS) { + cpair.setX(ha); + cpair.setY(dec); + } else { + return self(MccCoordPairKind::COORDS_KIND_HADEC_OBS); + } + } else if (cp_kind == MccCoordPairKind::COORDS_KIND_RADEC_APP) { + ha = lst + eo - ra; + if constexpr (PT::pairKind == MccCoordPairKind::COORDS_KIND_HADEC_APP) { + cpair.setX(ha); + cpair.setY(dec); + } else { + return self(MccCoordPairKind::COORDS_KIND_HADEC_APP); + } + } + + return error_t{}; + }; + + return comp_func(pkind); // ran transformation + } +}; + + +/* MCC-LIBRARY DEFAULT SKY POINT CLASS IMPLEMENTATION BASED ON THE ERFA LIBRARY */ + +typedef MccGenericSkyPoint MccSkyPoint; + +static_assert(mcc_skypoint_c, "!!!!"); + +} // namespace mcc::impl diff --git a/mcc_epoch.h b/mcc_epoch.h index e69de29..2d069ef 100644 --- a/mcc_epoch.h +++ b/mcc_epoch.h @@ -0,0 +1,412 @@ +#pragma once + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * IMPLEMENTATION OF CELESTIAL COORDINATES EPOCH * + * * + ****************************************************************************************/ + + + +#include + +#include "mcc_concepts.h" +#include "mcc_utils.h" + +namespace mcc::impl +{ + +class MccCelestialCoordEpoch : public mcc_coord_epoch_interface_t +{ + inline static const std::regex dateTimeISO8601Rx{ + " *[0-9]{4}-[0,1][0-9]-[0-2][0-9]T[0-2][0-9]:[0-6][0-9]:[0-6][0-9](\\.[0-9]+)? *"}; + + inline static const std::regex dateTimeJEpochRx{" *J[0-9]{4}(\\.[0-9]{1,})+ *"}; + inline static const std::regex dateTimeBEpochRx{" *B[0-9]{4}(\\.[0-9]{1,})+ *"}; + inline static const std::regex dateTimeMJDRx{" *([0-9]*[.])?[0-9]+([eE][-+]?[0-9]+)? *"}; + + + typedef std::chrono::duration> year_fp_t; + typedef std::chrono::duration> day_fp_t; + +public: + static constexpr auto J2000_UTC = + std::chrono::sys_days( + std::chrono::year_month_day(std::chrono::January / std::chrono::day(1) / std::chrono::year(2000))) + + std::chrono::hours(11) + std::chrono::minutes(58) + std::chrono::milliseconds(55816); + + static constexpr double J2000_MJD = 51544.5; + + + static MccCelestialCoordEpoch now() + { + MccCelestialCoordEpoch ep; + ep.fromTimePoint(std::chrono::system_clock::now()); + + return ep; + } + + MccCelestialCoordEpoch() : _UTC(J2000_UTC), _MJD(J2000_MJD), _JEpoch(2000.0) {} + + MccCelestialCoordEpoch(const MccCelestialCoordEpoch&) = default; + MccCelestialCoordEpoch(MccCelestialCoordEpoch&&) = default; + + MccCelestialCoordEpoch& operator=(const MccCelestialCoordEpoch&) = default; + MccCelestialCoordEpoch& operator=(MccCelestialCoordEpoch&&) = default; + + MccCelestialCoordEpoch(mcc_coord_epoch_c auto&& other) : MccCelestialCoordEpoch() + { + fromTimePoint(std::forward(other).UTC()); + } + + MccCelestialCoordEpoch& operator=(mcc_coord_epoch_c auto&& other) + { + fromTimePoint(std::forward(other).UTC()); + + return *this; + } + + MccCelestialCoordEpoch& operator=(traits::mcc_input_char_range auto&& str) + { + // ignore possible errors!!! + auto ok = fromCharRange(std::forward(str)); + + return *this; + } + + + template + MccCelestialCoordEpoch& operator=(std::chrono::time_point&& tp) + { + // ignore possible errors!!! + auto ok = fromTimePoint(std::forward(tp)); + + return *this; + } + + template + MccCelestialCoordEpoch& operator=(VT&& mjd) + requires std::is_arithmetic_v + { + // ignore possible errors!!! + auto ok = fromMJD(std::forward(mjd)); + + return *this; + } + + template + bool fromCharRange(IR&& str) + { + if constexpr (std::is_pointer_v>) { + return fromCharRange(std::string_view{str}); + } + + bool ret = false; + + std::string_view sv = utils::trimSpaces(std::forward(str)); + std::istringstream ist{std::string(sv)}; + + // try ISO8601 date ... + std::chrono::from_stream(ist, "%FT%T", _UTC); + if (ist.fail()) { // not ISO8601 date + // try MJD (floating-point number) ... + std::optional mjd = utils::numFromStr(sv); + if (mjd) { + _MJD = mjd.value(); + ret = fromMJD(); + } else { // not MJD + // try epoch (e.g. J2010.32) + if (sv[0] == 'J') { + auto jep = utils::numFromStr(sv.substr(1)); + if (jep) { + _JEpoch = jep.value(); + ret = fromJEpoch(); + } else { // ERROR!!! + ret = false; + } + } else { // ERROR!!! + ret = false; + } + } + } else { + ret = fromUTC(); + } + + return ret; + } + + template + bool fromTimePoint(std::chrono::time_point&& tp) + { + if constexpr (std::same_as) { + _UTC = std::chrono::time_point_cast(std::forward(tp)); + } else if constexpr (std::same_as) { + auto stp = std::chrono::utc_clock::to_sys(std::forward(tp)); + _UTC = std::chrono::time_point_cast(std::forward(stp)); + } else if constexpr (std::same_as) { + return fromTimePoint(ClockT::to_utc(std::forward(tp))); + } else if constexpr (std::same_as) { + return fromTimePoint(ClockT::to_utc(std::forward(tp))); + } else { + static_assert(false, "UNSUPPORTED CLOCK!!!"); + } + + + return fromUTC(); + } + + template + bool fromMJD(VT&& mjd) + requires std::is_arithmetic_v + { + _MJD = static_cast(std::forward(mjd)); + + return fromMJD(); + } + + template + MccCelestialCoordEpoch& operator+=(DT&& dt) + { + _UTC += std::chrono::duration_cast(std::forward
(dt)); + + _MJD += std::chrono::duration_cast(std::forward
(dt)).count(); + + _JEpoch += std::chrono::duration_cast(std::forward
(dt)).count(); + + return *this; + } + + template + MccCelestialCoordEpoch& operator-=(DT&& dt) + { + _UTC -= std::chrono::duration_cast(std::forward
(dt)); + + _MJD -= std::chrono::duration_cast(std::forward
(dt)).count(); + + _JEpoch -= std::chrono::duration_cast(std::forward
(dt)).count(); + + return *this; + } + + + template + friend MccCelestialCoordEpoch operator+(const MccCelestialCoordEpoch& lhs, const DT& dt) + { + MccCelestialCoordEpoch ep = lhs; + ep += dt; + + return ep; + } + template + friend MccCelestialCoordEpoch operator+(const DT& dt, const MccCelestialCoordEpoch& rhs) + { + return rhs + dt; + } + + template + friend MccCelestialCoordEpoch operator-(const MccCelestialCoordEpoch& lhs, const DT& dt) + { + MccCelestialCoordEpoch ep = lhs; + ep -= dt; + + return ep; + } + + friend auto operator-(const MccCelestialCoordEpoch& lhs, const MccCelestialCoordEpoch& rhs) + { + return lhs._UTC - rhs._UTC; + } + + + template + requires std::is_arithmetic_v + VT MJD() const + { + return _MJD; + } + + double MJD() const + { + return _MJD; + } + + template + std::chrono::sys_time
UTC() const + { + return std::chrono::time_point_cast
(_UTC); + } + + std::chrono::system_clock::time_point UTC() const + { + return _UTC; + } + + + template + R JEpoch(uint8_t prec = 0) const + { + std::string prec_str{"J{:"}; + if (prec > 0) { + prec_str += "."; + prec_str += std::to_string(prec); + } + prec_str += "f}"; + + std::string res = std::vformat(std::string_view{prec_str}, std::make_format_args(_JEpoch)); + + if constexpr (std::same_as) { + return res; + } + + R r; + std::ranges::copy(res, std::back_inserter(r)); + + return r; + } + + std::string JEpoch(uint8_t prec = 0) const + { + return JEpoch(prec); + } + + auto operator<=>(const MccCelestialCoordEpoch& rhs) const + { + return _UTC <=> rhs._UTC; + } + + auto operator==(const MccCelestialCoordEpoch& rhs) const + { + return _UTC == rhs._UTC; + } + +protected: + std::chrono::system_clock::time_point _UTC; + double _MJD; + double _JEpoch; + + bool fromUTC() + { + // modified Julian date (based on ERFA eraCal2jd) + auto dd = std::chrono::floor(_UTC); + std::chrono::year_month_day ymd{dd}; + + static constexpr std::chrono::year MIN_YEAR{-4799}; + + if (ymd.year() < MIN_YEAR) { + return false; + } + if (!ymd.month().ok()) { + return false; + } + + int64_t im = (unsigned)ymd.month(); + int64_t id = (unsigned)ymd.day(); + int64_t iy = (int)ymd.year(); + + int64_t my = (im - 14LL) / 12LL; + int64_t iypmy = iy + my; + + // integer part of result MJD + int64_t mjd_int = (1461LL * (iypmy + 4800LL)) / 4LL + (367LL * (im - 2LL - 12LL * my)) / 12LL - + (3LL * ((iypmy + 4900LL) / 100LL)) / 4LL + id - 2432076LL; + + _MJD = static_cast(mjd_int) + std::chrono::duration_cast(_UTC - dd).count(); + + _JEpoch = std::chrono::duration_cast(_UTC - J2000_UTC).count() + 2000.0; + + return true; + } + + bool fromMJD(bool only_time_point = false) + { + // Gregorian date from modified Julian date (based on ERFS eraJd2cal) + double f1 = -0.5; + long jd = std::round(_MJD); + double f2 = _MJD - jd; + jd += 2400001.0; + + double s = 0.5, cs = 0.0; + // double v[] = {f1, f2}; + + auto lmd = [&](double v) { + // double x = v; + // double t = s + x; + // cs += std::fabs(s) >= std::fabs(x) ? (s - t) + x : (x - t) + s; + double t = s + v; + cs += std::fabs(s) >= std::fabs(v) ? (s - t) + v : (v - t) + s; + s = t; + if (s >= 1.0) { + jd++; + s -= 1.0; + } + }; + + lmd(f1); + lmd(f2); + + double f = s + cs; + cs = f - s; + + if (f < 0.0) { + f = s + 1.0; + cs += (1.0 - f) + s; + s = f; + f = s + cs; + cs = f - s; + jd--; + } + + + if ((f - 1.0) >= -std::numeric_limits::epsilon() / 4.0) { + /* Compensated summation: assume that |s| <= 1.0. */ + double t = s - 1.0; + cs += (s - t) - 1.0; + s = t; + f = s + cs; + if (-std::numeric_limits::epsilon() / 2.0 < f) { + jd++; + f = std::max(f, 0.0); + } + } + + long l = jd + 68569L; + long n = (4L * l) / 146097L; + l -= (146097L * n + 3L) / 4L; + long i = (4000L * (l + 1L)) / 1461001L; + l -= (1461L * i) / 4L - 31L; + long k = (80L * l) / 2447L; + + auto day = std::chrono::day(l - (2447L * k) / 80L); + l = k / 11L; + auto month = std::chrono::month(k + 2L - 12L * l); + auto year = std::chrono::year(100L * (n - 49L) + i + l); + + auto day_frac = day_fp_t(f); + + // _UTC = years + month + days + day_frac; + _UTC = std::chrono::sys_days(std::chrono::year_month_day(month / day / year)); + _UTC += std::chrono::duration_cast(day_frac); + + if (!only_time_point) { + _JEpoch = 2000.0 + (_MJD - J2000_MJD) / 365.25; + } + + return true; + } + + bool fromJEpoch() + { + _MJD = J2000_MJD + (_JEpoch - 2000.0) * 365.25; + + return fromMJD(true); + } +}; + + +static_assert(mcc_coord_epoch_c, "!!!"); + + +} // namespace mcc::impl diff --git a/mcc_error.h b/mcc_error.h new file mode 100644 index 0000000..f9defbf --- /dev/null +++ b/mcc_error.h @@ -0,0 +1,124 @@ +#pragma once + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * IMPLEMENTATION OF OPERATIONAL ERROR * + * * + ****************************************************************************************/ + + + +#include +#include +#include + +#include "mcc_concepts.h" + +namespace mcc::impl +{ + +typedef std::error_code MccError; // library-wide definition of operational error + +} // namespace mcc::impl + +template <> +struct std::formatter { + template + constexpr ParseContext::iterator parse(ParseContext& ctx) + { + auto it = ctx.begin(); + if (it == ctx.end()) { + return it; + } + + _currFmt.clear(); + _delim = " "; + + for (; it != ctx.end(); ++it) { + switch (*it) { + case '#': // numerical error value + _currFmt.push_back(*it); + break; + case '@': // error category name + _currFmt.push_back(*it); + break; + case '^': // error message + _currFmt.push_back(*it); + break; + case '_': + // while (it++ != ctx.end() || it++ != '}' || it++ != '_') { + // _currFmt.push_back(*(++it)); + // } + + if (it++ != ctx.end() || it++ != '}') { + _delim = *(++it); + } + case '}': + if (_currFmt.empty()) { + _currFmt = "#@^"; + } + return it; + default: + break; + } + } + + return it; + } + + template + FmtContext::iterator format(mcc::impl::MccError const& err, FmtContext& ctx) const + { + std::ostringstream out; + + size_t idx = 0; + for (auto const& fmt_sym : _currFmt) { + switch (fmt_sym) { + case '#': + out << err.value(); + ++idx; + break; + case '@': + out << err.category().name(); + ++idx; + break; + case '^': + out << err.message(); + ++idx; + break; + default: + break; + } + if (idx < _currFmt.size()) { + out << _delim; + } + } + + return std::ranges::copy(std::move(out).str(), ctx.out()).out; + } + +private: + std::string _currFmt{}, _delim{" "}; +}; + + +static_assert(mcc::mcc_error_c, ""); + + +// a helper formatter impelementation + +template + requires std::is_enum_v +struct std::formatter : std::formatter, char> { + auto format(T e, auto& ctx) const + { + return formatter>::format(std::underlying_type_t(e), ctx); + } +}; + +enum class EE : int { A, B, C }; + +static_assert(mcc::mcc_error_c, ""); diff --git a/mcc_pcm.h b/mcc_pcm.h new file mode 100644 index 0000000..4159ee2 --- /dev/null +++ b/mcc_pcm.h @@ -0,0 +1,470 @@ + +#pragma once + + +/* MOUNT CONTROL COMPONENTS LIBRARY */ + +/* A REFERENCE "POINTING-CORRECTION-MODEL" CLASS IMPLEMENTATION */ + + +#include + +#ifdef USE_BSPLINE_PCM +#include "fitpack/mcc_bsplines.h" +#endif + +#include "mcc_concepts.h" +#include "mcc_coordinate.h" + +namespace mcc::impl +{ + +enum class MccDefaultPCMErrorCode : int { + ERROR_OK, + ERROR_CCTE, +#ifdef USE_BSPLINE_PCM + ERROR_INVALID_INPUTS_BISPLEV, +#endif + ERROR_EXCEED_MAX_ITERS, + ERROR_NULLPTR +}; + +/* error category definition */ + +// error category +struct MccDefaultPCMCategory : public std::error_category { + MccDefaultPCMCategory() : std::error_category() {} + + const char* name() const noexcept + { + return "ADC_GENERIC_DEVICE"; + } + + std::string message(int ec) const + { + MccDefaultPCMErrorCode err = static_cast(ec); + + switch (err) { + case MccDefaultPCMErrorCode::ERROR_OK: + return "OK"; + case MccDefaultPCMErrorCode::ERROR_CCTE: + return "CCTE calculation error"; +#ifdef USE_BSPLINE_PCM + case MccDefaultPCMErrorCode::ERROR_INVALID_INPUTS_BISPLEV: + return "invalid input arguments for bispev"; +#endif + case MccDefaultPCMErrorCode::ERROR_EXCEED_MAX_ITERS: + return "exceed maximum of iterations number"; + case MccDefaultPCMErrorCode::ERROR_NULLPTR: + return "nullptr input argument"; + default: + return "UNKNOWN"; + } + } + + static const MccDefaultPCMCategory& get() + { + static const MccDefaultPCMCategory constInst; + return constInst; + } +}; + + +inline std::error_code make_error_code(MccDefaultPCMErrorCode ec) +{ + return std::error_code(static_cast(ec), MccDefaultPCMCategory::get()); +} +} // namespace mcc::impl + + +namespace std +{ + +template <> +class is_error_code_enum : public true_type +{ +}; + +} // namespace std + + + +namespace mcc::impl +{ + + +// type of PCM corrections (algorithm used): +// PCM_TYPE_GEOMETRY - "classic" geometry-based correction coefficients +// PCM_TYPE_GEOMETRY_BSPLINE - previous one and additional 2D B-spline corrections +// PCM_TYPE_BSPLINE - pure 2D B-spline corrections +enum class MccDefaultPCMType { PCM_TYPE_GEOMETRY, PCM_TYPE_GEOMETRY_BSPLINE, PCM_TYPE_BSPLINE }; + +template +static constexpr std::string_view MccDefaultPCMTypeString = + TYPE == MccDefaultPCMType::PCM_TYPE_GEOMETRY ? "GEOMETRY" +#ifdef USE_BSPLINE_PCM + : TYPE == MccDefaultPCMType::PCM_TYPE_GEOMETRY_BSPLINE ? "GEOMETRY-BSPLINE" + : TYPE == MccDefaultPCMType::PCM_TYPE_GEOMETRY_BSPLINE ? "BSPLINE" +#endif + : "UNKNOWN"; + +template +class MccDefaultPCM : public mcc_pcm_interface_t +{ +public: + static constexpr MccMountType mountType = MOUNT_TYPE; + +#ifdef USE_BSPLINE_PCM + static constexpr std::string_view pcmName{"MCC-GEOMETRY-BSPLINES-PCM"}; +#else + static constexpr std::string_view pcmName{"MCC-GEOMETRY-ONLY-PCM"}; +#endif + + typedef std::error_code error_t; + typedef double coord_t; + + + // "classic" geometric PCM coefficients + struct pcm_geom_coeffs_t { + typedef double coeff_t; + + coeff_t zeroPointX; + coeff_t zeroPointY; + coeff_t collimationErr; // tube collimation error + coeff_t nonperpendErr; // X-Y axes nonperpendicularity + coeff_t misalignErr1; // misalignment of hour-angle/azimuth axis: left-right for equatorial, East-West for + // alt-azimuthal + coeff_t misalignErr2; // misalignment of hour-angle/azimuth axis: vertical for equatorial, North-South for + // alt-azimuthal + + coeff_t tubeFlexure; + coeff_t forkFlexure; + coeff_t DECaxisFlexure; // declination axis flexure + }; + +#ifdef USE_BSPLINE_PCM + // B-splines related data structure (coefficients, knots ...) + struct pcm_bspline_t { + typedef double knot_t; + typedef double coeff_t; + + size_t bsplDegreeX = 3; + size_t bsplDegreeY = 3; + + std::vector knotsX{}; + std::vector knotsY{}; + + std::vector coeffsX{}; + std::vector coeffsY{}; + }; +#endif + + struct pcm_data_t { + MccDefaultPCMType type{MccDefaultPCMType::PCM_TYPE_GEOMETRY}; + double siteLatitude{0.0}; // in radians + + // from encoder to observed celestial + pcm_geom_coeffs_t geomCoefficients{}; +#ifdef USE_BSPLINE_PCM + pcm_bspline_t bspline{}; +#endif + + // from observed celestial to encoder + pcm_geom_coeffs_t inverseGeomCoefficients{}; +#ifdef USE_BSPLINE_PCM + pcm_bspline_t inverseBspline{}; +#endif + }; + + // constructors + + MccDefaultPCM() = default; + MccDefaultPCM(pcm_data_t pdata) : MccDefaultPCM() + { + _pcmData = std::move(pdata); + } + + MccDefaultPCM(MccDefaultPCM&& other) = default; + MccDefaultPCM& operator=(MccDefaultPCM&& other) = default; + + MccDefaultPCM(const MccDefaultPCM&) = delete; + MccDefaultPCM& operator=(const MccDefaultPCM&) = delete; + + virtual ~MccDefaultPCM() = default; + + // virtual ~MccDefaultPCM() { + // // _pcmData.geomCoefficients.DECaxisFlexure = 0.0; + // }; + + void setPCMData(pcm_data_t pdata) + { + std::lock_guard lock(*_pcmDataMutex); + + _pcmData = std::move(pdata); + + _cosPhi = std::cos(_pcmData.siteLatitude); + _sinPhi = std::sin(_pcmData.siteLatitude); + } + + + pcm_data_t getPCMData() const + { + std::lock_guard lock(*_pcmDataMutex); + + return _pcmData; + } + + void setPCMType(MccDefaultPCMType type) + { + std::lock_guard lock(*_pcmDataMutex); + +#ifdef USE_BSPLINE_PCM + _pcmData.type = type; +#else + _pcmData.type = MccDefaultPCMType::PCM_TYPE_GEOMETRY; +#endif + } + + MccDefaultPCMType getPCMType() const + { + std::lock_guard lock(*_pcmDataMutex); + + return _pcmData.type; + } + + // The computed PCM quantities must be interpretated as: + // observed_X = encoder_X + res.pcmX + // observed_Y = encoder_Y + res.pcmY + // so, input hw_coord is assumed to be coordinates pair of mount axis encoder readouts + template + error_t computePCM(mcc_coord_pair_c auto const& hw_coord, mcc_pcm_result_c auto* res, T* obs_skycoord = nullptr) + requires(mcc_skypoint_c || std::is_null_pointer_v) + { + if (res == nullptr) { + return MccDefaultPCMErrorCode::ERROR_NULLPTR; + } + + std::lock_guard lock(*_pcmDataMutex); + + res->pcmX = 0.0; + res->pcmY = 0.0; + + auto ret = _compResult(hw_coord.x(), hw_coord.y(), res, false); + if (ret) { + return ret; + } + + if constexpr (mcc_is_equatorial_mount) { // equatorial (HA and DEC axes) + if constexpr (mcc_skypoint_c) { + obs_skycoord->from(MccSkyHADEC_OBS{double(hw_coord.x() + res->pcmX), double(hw_coord.y() + res->pcmY), + hw_coord.epoch()}); + } + + } else if constexpr (mcc_is_altaz_mount) { + if constexpr (mcc_skypoint_c) { + obs_skycoord->from( + MccSkyAZZD{double(hw_coord.x() + res->pcmX), double(hw_coord.y() + res->pcmY), hw_coord.epoch()}); + } + } else { + static_assert(false, "UNSUPPORTED MOUNT TYPE"); + } + + + return MccDefaultPCMErrorCode::ERROR_OK; + } + + // + // computed inverse PCM corrections must be interpretated as: + // X_encoder = X_observed + res->pcmX + // Y_encoder = Y_observed + res->pcmY + // + template + error_t computeInversePCM(mcc_skypoint_c auto const& obs_skycoord, mcc_pcm_result_c auto* res, T* hw_pt = nullptr) + requires(mcc_coord_pair_c || std::is_null_pointer_v) + { + error_t ret = MccDefaultPCMErrorCode::ERROR_OK; + + if constexpr (mcc_coord_pair_c) { + static_assert( + T::pairKind == MccCoordPairKind::COORDS_KIND_GENERIC || T::pairKind == MccCoordPairKind::COORDS_KIND_XY, + "Invalid output coordinate pair type!"); + } + + // to be computed as observed celestial X and Y cordinate according to mount type (HA-DEC or AZ-ZD) + double x, y; + + auto getXY = [&, this](auto& cp) { + auto err = obs_skycoord.toAtSameEpoch(cp); + if (err) { + return mcc_deduced_err(err, MccDefaultPCMErrorCode::ERROR_CCTE); + } + + x = cp.x(); + y = cp.y(); + + return MccDefaultPCMErrorCode::ERROR_OK; + }; + + if constexpr (mcc_is_equatorial_mount) { + MccSkyHADEC_OBS hadec; + ret = getXY(hadec); + } else if constexpr (mcc_is_altaz_mount) { + MccSkyAZZD azzd; + ret = getXY(azzd); + } + + std::lock_guard lock(*_pcmDataMutex); + + ret = _compResult(x, y, res, true); + if (!ret) { + if constexpr (mcc_coord_pair_c) { + *hw_pt = MccCoordPair{x + res->pcmX, y + res->pcmY}; + } + } + + return ret; + } + + /* + template + error_t computeInversePCM(mcc_skypoint_c auto const& obs_skycoord, + mcc_pcm_result_c auto* result, + T* hw_pt = nullptr) + requires(mcc_coord_pair_c || std::is_null_pointer_v) + { + error_t ret = MccDefaultPCMErrorCode::ERROR_OK; + + if constexpr (mcc_coord_pair_c) { + static_assert( + T::pairKind == MccCoordPairKind::COORDS_KIND_GENERIC || T::pairKind == MccCoordPairKind::COORDS_KIND_XY, + "Invalid output coordinate pair type!"); + } + + double x, y; + + auto comp_func = [&, this](auto& cp) { + auto err = obs_skycoord.toAtSameEpoch(cp); + if (err) { + return mcc_deduced_err(err, MccDefaultPCMErrorCode::ERROR_CCTE); + } + + x = cp.x(); + y = cp.y(); + + return computePCM(cp, result); + }; + + + // for small corrections only!!! + if constexpr (mcc_is_equatorial_mount) { + MccSkyHADEC_OBS hadec; + ret = comp_func(hadec); + } else if constexpr (mcc_is_altaz_mount) { + MccSkyAZZD azzd; + ret = comp_func(azzd); + } + + if (ret) { + return ret; + } + + if constexpr (mcc_coord_pair_c) { + *hw_pt = MccCoordPair{x - result->pcmX, y - result->pcmY}; + } + + return ret; + } + */ + +private: + pcm_data_t _pcmData{}; + double _cosPhi{}, _sinPhi{}; + + std::unique_ptr _pcmDataMutex{new std::mutex}; + + error_t _compResult(double x, double y, mcc_pcm_result_c auto* res, bool inverse) + { + pcm_geom_coeffs_t* geom_coeffs; +#ifdef USE_BSPLINE_PCM + pcm_bspline_t* bspline; +#endif + + geom_coeffs = inverse ? &_pcmData.inverseGeomCoefficients : &_pcmData.geomCoefficients; +#ifdef USE_BSPLINE_PCM + bspline = inverse ? &_pcmData.inverseBspline : &_pcmData.bspline; +#endif + + if (_pcmData.type == MccDefaultPCMType::PCM_TYPE_GEOMETRY +#ifdef USE_BSPLINE_PCM + || _pcmData.type == MccDefaultPCMType::PCM_TYPE_GEOMETRY_BSPLINE +#endif + ) { + const auto tanY = std::tan(y); + const auto sinX = std::sin(x); + const auto cosX = std::cos(x); + const auto cosY = std::cos(y); + + + if (utils::isEqual(cosY, 0.0)) { + res->pcmX = _pcmData.geomCoefficients.zeroPointX; + } else { + res->pcmX = geom_coeffs->zeroPointX + geom_coeffs->collimationErr / cosY + + geom_coeffs->nonperpendErr * tanY - geom_coeffs->misalignErr1 * cosX * tanY + + geom_coeffs->misalignErr2 * sinX * tanY + geom_coeffs->tubeFlexure * _cosPhi * sinX / cosY - + geom_coeffs->DECaxisFlexure * (_cosPhi * cosX + _sinPhi * tanY); + } + + res->pcmY = geom_coeffs->zeroPointY + geom_coeffs->misalignErr1 * sinX + geom_coeffs->misalignErr2 * cosX + + geom_coeffs->tubeFlexure * (_cosPhi * cosX * std::sin(y) - _sinPhi * cosY); + + if constexpr (mountType == MccMountType::FORK_TYPE) { + if (!utils::isEqual(cosX, 0.0)) { + res->pcmY += geom_coeffs->forkFlexure / cosX; + } + } + } + + +#ifdef USE_BSPLINE_PCM + if (_pcmData.type == MccDefaultPCMType::PCM_TYPE_BSPLINE || + _pcmData.type == MccDefaultPCMType::PCM_TYPE_GEOMETRY_BSPLINE) { + double spl_valX, spl_valY; + + int ret = bsplines::fitpack_eval_spl2d(bspline->knotsX, bspline->knotsY, bspline->coeffsX, x, y, spl_valX, + bspline->bsplDegreeX, bspline->bsplDegreeY); + + if (ret) { + res->pcmX = std::numeric_limits::quiet_NaN(); + res->pcmY = std::numeric_limits::quiet_NaN(); + return MccDefaultPCMErrorCode::ERROR_INVALID_INPUTS_BISPLEV; + } + + + ret = bsplines::fitpack_eval_spl2d(bspline->knotsX, bspline->knotsY, bspline->coeffsY, x, y, spl_valY, + bspline->bsplDegreeX, bspline->bsplDegreeY); + + if (ret) { + res->pcmX = std::numeric_limits::quiet_NaN(); + res->pcmY = std::numeric_limits::quiet_NaN(); + return MccDefaultPCMErrorCode::ERROR_INVALID_INPUTS_BISPLEV; + } + + + res->pcmX += spl_valX; + res->pcmY += spl_valY; + } +#endif + + return MccDefaultPCMErrorCode::ERROR_OK; + } +}; + + +typedef MccDefaultPCM MccMountDefaultAltAzPec; +typedef MccDefaultPCM MccMountDefaultForkPec; + +static_assert(mcc_pcm_c, ""); +static_assert(std::movable); + + +} // namespace mcc::impl diff --git a/mcc_pzone.h b/mcc_pzone.h new file mode 100644 index 0000000..4f0baa1 --- /dev/null +++ b/mcc_pzone.h @@ -0,0 +1,455 @@ +#pragma once + + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * IMPLEMENTATION OF SOME SIMPLE PROHIBITED ZONES * + * * + ****************************************************************************************/ + +#include "mcc_concepts.h" +#include "mcc_constants.h" +#include "mcc_coordinate.h" + +namespace mcc::impl +{ + + +enum class MccPZoneErrorCode : int { ERROR_OK, ERROR_NULLPTR, ERROR_COORD_TRANSFROM, ERROR_PCM_COMP }; + +} // namespace mcc::impl + +namespace std +{ + +template <> +class is_error_code_enum : public true_type +{ +}; + +} // namespace std + + +namespace mcc::impl +{ + +// error category +struct MccPZoneCategory : public std::error_category { + MccPZoneCategory() : std::error_category() {} + + const char* name() const noexcept + { + return "ALTITUDE-LIMIT-PZ"; + } + + std::string message(int ec) const + { + MccPZoneErrorCode err = static_cast(ec); + + switch (err) { + case MccPZoneErrorCode::ERROR_OK: + return "OK"; + case MccPZoneErrorCode::ERROR_NULLPTR: + return "input argument os nullptr"; + case MccPZoneErrorCode::ERROR_COORD_TRANSFROM: + return "coordinate transformation error"; + case MccPZoneErrorCode::ERROR_PCM_COMP: + return "PCM computation error"; + default: + return "UNKNOWN"; + } + } + + static const MccPZoneCategory& get() + { + static const MccPZoneCategory constInst; + return constInst; + } +}; + + +inline std::error_code make_error_code(MccPZoneErrorCode ec) +{ + return std::error_code(static_cast(ec), MccPZoneCategory::get()); +} + + +enum class MccAltLimitKind { MIN_ALT_LIMIT, MAX_ALT_LIMIT }; + +template +class MccAltLimitPZ : public mcc_pzone_interface_t +{ +public: + static constexpr MccProhibitedZonePolicy pzPolicy = MccProhibitedZonePolicy::PZ_POLICY_STOP; + + typedef std::error_code error_t; + + MccAltLimitPZ(mcc_angle_c auto const& alt_limit, mcc_angle_c auto const& latitude) + : _altLimit(MccAngle(alt_limit).normalize()), + _cosALim(cos(_altLimit)), + _sinAlim(sin(_altLimit)), + _cosLat(cos(latitude)), + _sinLat(sin(latitude)), + _absLat(abs(latitude)), + _latLim(MCC_TWO_PI - _altLimit) + { + } + + + MccAltLimitPZ(MccAltLimitPZ&&) = default; + MccAltLimitPZ(const MccAltLimitPZ&) = default; + + static constexpr std::string_view pzoneName = KIND == MccAltLimitKind::MIN_ALT_LIMIT ? "MINALT-ZONE" + : KIND == MccAltLimitKind::MAX_ALT_LIMIT ? "MAXALT-ZONE" + : "ALTLIMIT-UNKNOWN"; + + + error_t inPZone(mcc_skypoint_c auto const& coords, bool* result) + { + if (result == nullptr) { + return MccPZoneErrorCode::ERROR_NULLPTR; + } + + error_t ret = MccPZoneErrorCode::ERROR_OK; + + + MccSkyAZALT azalt; + auto ccte_err = coords.to(azalt); + if (ccte_err) { + return mcc_deduced_err(ccte_err, MccPZoneErrorCode::ERROR_COORD_TRANSFROM); + } + + + if constexpr (KIND == MccAltLimitKind::MIN_ALT_LIMIT) { + *result = azalt.y() <= _altLimit; + } else if constexpr (KIND == MccAltLimitKind::MAX_ALT_LIMIT) { + *result = azalt.y() >= _altLimit; + } + + return ret; + } + + + error_t timeToPZone(mcc_skypoint_c auto const& coords, traits::mcc_time_duration_c auto* res_time) + { + using res_t = std::remove_cvref_t; + + if (res_time == nullptr) { + return MccPZoneErrorCode::ERROR_NULLPTR; + } + + error_t ret = MccPZoneErrorCode::ERROR_OK; + + bool inzone; + ret = inPZone(coords, &inzone); + if (ret) { + return ret; + } + + if (inzone) { + *res_time = res_t{0}; + return ret; + } + + MccSkyHADEC_OBS hadec; + + auto ccte_err = coords.to(hadec); + if (ccte_err) { + return mcc_deduced_err(ccte_err, MccPZoneErrorCode::ERROR_COORD_TRANSFROM); + } + + + if (!doesObjectReachZone(hadec.y())) { + *res_time = MCC_INFINITE_DURATION_V; + return ret; + } + + if constexpr (KIND == + MccAltLimitKind::MIN_ALT_LIMIT) { // the closest time point is one after upper culmination + compute(hadec.x(), hadec.y(), false, res_time); + } else if constexpr (KIND == MccAltLimitKind::MAX_ALT_LIMIT) { // the closest time point is one before upper + // culmination + compute(hadec.x(), hadec.y(), true, res_time); + } + + return ret; + } + + error_t timeFromPZone(mcc_skypoint_c auto const& coords, traits::mcc_time_duration_c auto* res_time) + { + using res_t = std::remove_cvref_t; + + if (res_time == nullptr) { + return MccPZoneErrorCode::ERROR_NULLPTR; + } + + error_t ret = MccPZoneErrorCode::ERROR_OK; + + bool inzone; + ret = inPZone(coords, &inzone); + if (ret) { + return ret; + } + + if (!inzone) { + *res_time = res_t{0}; + return ret; + } + + MccSkyHADEC_OBS hadec; + + auto ccte_err = coords.to(hadec); + if (ccte_err) { + return mcc_deduced_err(ccte_err, MccPZoneErrorCode::ERROR_COORD_TRANSFROM); + } + + if (!doesObjectExitFromZone(hadec.y())) { + *res_time = MCC_INFINITE_DURATION_V; + return ret; + } + + if (!doesObjectReachZone(hadec.y())) { + *res_time = res_t{0}; + return ret; + } + + if constexpr (KIND == + MccAltLimitKind::MIN_ALT_LIMIT) { // the closest time point is one before upper culmination + compute(hadec.x(), hadec.y(), true, res_time); + } else if constexpr (KIND == MccAltLimitKind::MAX_ALT_LIMIT) { // the closest time point is one after upper + // culmination + compute(hadec.x(), hadec.y(), false, res_time); + } + + return ret; + } + + +protected: + double _altLimit, _cosALim, _sinAlim; + double _cosLat, _sinLat, _absLat, _latLim; + + bool doesObjectReachZone(const double& dec_app) + { + // check for limit conditions + auto dd = std::abs(dec_app); + + if constexpr (KIND == MccAltLimitKind::MIN_ALT_LIMIT) { + dd += _altLimit; + + if (dd > _latLim) { // never fall below altitude limit + return false; + } + } else if constexpr (KIND == MccAltLimitKind::MAX_ALT_LIMIT) { + auto z = std::numbers::pi / 2.0 - _altLimit; + if ((dd < (_absLat - z)) || (dd > (_absLat + z))) { // never rise above altitude limit + return false; + } + // if ((dd < (_absLat - _altLimit)) || (dd > (_absLat + _altLimit))) { // never rise above altitude limit + // return false; + // } + } else { + static_assert(false, "UNKNOWN ALTITUDE LIMIT TYPE!"); + } + + return true; + } + + + bool doesObjectExitFromZone(const double& dec_app) + { + // check for limit conditions + auto dd = std::abs(dec_app); + + if constexpr (KIND == MccAltLimitKind::MIN_ALT_LIMIT) { + dd -= _altLimit; + + if (-dd <= -_latLim) { // always below altitude limit + return false; + } + } else if constexpr (KIND == MccAltLimitKind::MAX_ALT_LIMIT) { + if ((dd >= (_absLat - _altLimit)) || (dd <= (_absLat + _altLimit))) { // always above altitude limit + return false; + } + } else { + static_assert(false, "UNKNOWN ALTITUDE LIMIT TYPE!"); + } + + return true; + } + + + void compute(const double& ha_app, + const double& dec_app, + bool before_upper_culm, + traits::mcc_time_duration_c auto* result) + { + using res_t = std::remove_cvref_t; + using period_t = typename res_t::period; + + double cos_ha = (_sinAlim - std::sin(dec_app) * _sinLat) / std::cos(dec_app) / _cosLat; + + if (cos_ha > 1.0) { // should not be! + *result = MCC_INFINITE_DURATION_V; + return; + } + + double ha; + // WARNING: what about south hemisphere?!!! + if (before_upper_culm) { + ha = -std::acos(cos_ha); // HA before upper culmination + } else { + ha = std::acos(cos_ha); // HA after upper culmination!! + } + + auto time_ang = ha - ha_app; // in sideral time scale + + if (time_ang < 0.0) { // next day + time_ang += MCC_TWO_PI; + } + + time_ang /= MCC_SIDERAL_TO_UT1_RATIO; // to UT1 time scale + + std::chrono::nanoseconds ns{ + static_cast(time_ang * 43200.0 / std::numbers::pi * 1.0E9)}; + + period_t rat; + *result = res_t{static_cast(time_ang * 43200.0 / std::numbers::pi * rat.den / rat.num)}; + } +}; + + + +/* co-longitude axis (HA or AZ) limit switch prohibited zone */ + +template +class MccAxisLimitSwitchPZ : public mcc_pzone_interface_t +{ +public: + static_assert(AXIS_KIND == MccCoordKind::COORDS_KIND_AZ || AXIS_KIND == MccCoordKind::COORDS_KIND_HA_OBS, + "UNSUPPORTED AXIS TYPE!"); + + typedef std::error_code error_t; + + static constexpr MccCoordKind axisKind = AXIS_KIND; + + static constexpr MccProhibitedZonePolicy pzPolicy = MccProhibitedZonePolicy::PZ_POLICY_FLIP; + + // + // min_limit_val and max_limit_val are hardware encoder angles in radians! + // + MccAxisLimitSwitchPZ(mcc_angle_c auto const& min_limit_val, + mcc_angle_c auto const& max_limit_val, + mcc_pcm_c auto* pcm) + : _minLimit(min_limit_val), _maxLimit(max_limit_val) + { + _correctForPCM = [pcm](MccSkyPoint const& skypt, MccGenXY* hw_coords) { + struct pcm_res_t { + double pcmX, pcmY; + }; + + pcm_res_t res; + + auto err = pcm->computeInversePCM(skypt, &res, hw_coords); + + return mcc_deduced_err(err, MccPZoneErrorCode::ERROR_PCM_COMP); + }; + } + + + static constexpr std::string_view pzoneName = axisKind == MccCoordKind::COORDS_KIND_AZ ? "AZ_AXIS-LIMITSWITCH_ZONE" + : axisKind == MccCoordKind::COORDS_KIND_HA_OBS + ? "HA_AXIS-LIMITSWITCH_ZONE" + : "UKNOWN"; + + + + error_t inPZone(mcc_skypoint_c auto const& coords, bool* result) + { + if (result == nullptr) { + return MccPZoneErrorCode::ERROR_NULLPTR; + } + + MccGenXY xy; + + if (coords.pairKind() != MccCoordPairKind::COORDS_KIND_XY) { + auto err = _correctForPCM(coords, &xy); + if (err) { + return err; + } + } else { // 'coords' is interpretated as hardware (encoder readout) coordinates + coords.to(xy); + } + + double x = xy.x(); + *result = (x > _maxLimit) || (x < _minLimit); + + return MccPZoneErrorCode::ERROR_OK; + } + + // time to reach maximal limit + error_t timeToPZone(mcc_skypoint_c auto const& coords, traits::mcc_time_duration_c auto* res_time) + { + return _computeTime(coords, res_time, false); + } + + // time to reach minimal limit + error_t timeFromPZone(mcc_skypoint_c auto const& coords, traits::mcc_time_duration_c auto* res_time) + { + return _computeTime(coords, res_time, true); + } + +protected: + double _minLimit, _maxLimit; + + std::function _correctForPCM{}; + + error_t _computeTime(mcc_skypoint_c auto const& coords, traits::mcc_time_duration_c auto* res_time, bool from_time) + { + using res_t = std::remove_cvref_t; + using period_t = typename res_t::period; + + double time_ang; + + if (res_time == nullptr) { + return MccPZoneErrorCode::ERROR_NULLPTR; + } + + + MccGenXY xy; + + if (coords.pairKind() != MccCoordPairKind::COORDS_KIND_XY) { + auto err = _correctForPCM(coords, &xy); + if (err) { + return err; + } + } else { // 'coords' is interpretated as hardware (encoder readout) coordinates + coords.to(xy); + } + + double x = xy.x(); + + if constexpr (AXIS_KIND == MccCoordKind::COORDS_KIND_HA_OBS) { + if (from_time) { // timeFromPZone + time_ang = (_minLimit - x) / MCC_SIDERAL_TO_UT1_RATIO; // to UT1 scale + } else { // timeToPZone + time_ang = (_maxLimit - x) / MCC_SIDERAL_TO_UT1_RATIO; // to UT1 scale + } + } else if constexpr (AXIS_KIND == MccCoordKind::COORDS_KIND_AZ) { + } + + std::chrono::nanoseconds ns{ + static_cast(time_ang * 43200.0 / std::numbers::pi * 1.0E9)}; + + period_t rat; + *res_time = res_t{static_cast(time_ang * 43200.0 / std::numbers::pi * rat.den / rat.num)}; + + return MccPZoneErrorCode::ERROR_OK; + } +}; + + +} // namespace mcc::impl diff --git a/mcc_pzone_container.h b/mcc_pzone_container.h new file mode 100644 index 0000000..0151c6a --- /dev/null +++ b/mcc_pzone_container.h @@ -0,0 +1,231 @@ +#pragma once + + + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * IMPLEMENTATION OF PROHIBITED ZONES CONTAINER * + * * + ****************************************************************************************/ + +#include "mcc_concepts.h" +#include "mcc_coordinate.h" + + +namespace mcc::impl +{ + +enum class MccPZoneContainerErrorCode : int { + ERROR_OK, + ERROR_NULLPTR, + ERROR_INVALID_SIZE, + ERROR_INZONE_FUNC, + ERROR_TIMETO_FUNC, + ERROR_TIMEFROM_FUNC, + ERROR_INTERSECT_FUNC +}; + +} // namespace mcc::impl + + +namespace std +{ + +template <> +class is_error_code_enum : public true_type +{ +}; + +} // namespace std + + + +namespace mcc::impl +{ + +// error category +struct MccPZoneContainerCategory : public std::error_category { + MccPZoneContainerCategory() : std::error_category() {} + + const char* name() const noexcept + { + return "ALTITUDE-LIMIT-PZ"; + } + + std::string message(int ec) const + { + MccPZoneContainerErrorCode err = static_cast(ec); + + switch (err) { + case MccPZoneContainerErrorCode::ERROR_OK: + return "OK"; + case MccPZoneContainerErrorCode::ERROR_NULLPTR: + return "nullptr argument"; + case MccPZoneContainerErrorCode::ERROR_INVALID_SIZE: + return "invalid range size of input argument"; + case MccPZoneContainerErrorCode::ERROR_INZONE_FUNC: + return "inPZone method error"; + case MccPZoneContainerErrorCode::ERROR_TIMETO_FUNC: + return "timeToPZone method error"; + case MccPZoneContainerErrorCode::ERROR_TIMEFROM_FUNC: + return "timeFromPZone method error"; + case MccPZoneContainerErrorCode::ERROR_INTERSECT_FUNC: + return "intersectPZone method error"; + default: + return "UNKNOWN"; + } + } + + static const MccPZoneContainerCategory& get() + { + static const MccPZoneContainerCategory constInst; + return constInst; + } +}; + + +inline std::error_code make_error_code(MccPZoneContainerErrorCode ec) +{ + return std::error_code(static_cast(ec), MccPZoneContainerCategory::get()); +} + + +// template +class MccPZoneContainer : public mcc_pzone_container_interface_t +{ +public: + typedef std::error_code error_t; + + MccPZoneContainer() = default; + + MccPZoneContainer(MccPZoneContainer&&) = default; + MccPZoneContainer(const MccPZoneContainer&) = default; + + MccPZoneContainer& operator=(MccPZoneContainer&&) = default; + MccPZoneContainer& operator=(const MccPZoneContainer&) = default; + + + virtual ~MccPZoneContainer() = default; + + + size_t addPZone(mcc_pzone_c auto zone) + { + auto sptr = std::make_shared(std::move(zone)); + + _inZoneFunc.emplace_back([sptr](MccSkyPoint const& pt, bool* res) { + auto err = sptr->inPZone(pt, res); + if (err) { + return mcc_deduced_err(err, MccPZoneContainerErrorCode::ERROR_INZONE_FUNC); + } + + return MccPZoneContainerErrorCode::ERROR_OK; + }); + + + _timeToZoneFunc.emplace_back([sptr](MccSkyPoint const& pt, duration_t* res) { + auto err = sptr->timeToPZone(pt, res); + if (err) { + return mcc_deduced_err(err, MccPZoneContainerErrorCode::ERROR_TIMETO_FUNC); + } + + return MccPZoneContainerErrorCode::ERROR_OK; + }); + + + _timeFromZoneFunc.emplace_back([sptr](MccSkyPoint const& pt, duration_t* res) { + auto err = sptr->timeFromPZone(pt, res); + if (err) { + return mcc_deduced_err(err, MccPZoneContainerErrorCode::ERROR_TIMEFROM_FUNC); + } + + return MccPZoneContainerErrorCode::ERROR_OK; + }); + + return _inZoneFunc.size(); + } + + void clearZones() + { + _inZoneFunc.clear(); + _timeToZoneFunc.clear(); + _timeFromZoneFunc.clear(); + } + + + error_t inPZone(mcc_skypoint_c auto const& coords, bool* at_least_one, std::ranges::output_range auto* result) + { + auto err = forEach(_inZoneFunc, coords, result); + if (!err) { + *at_least_one = false; + for (auto const& r : *result) { + if (r) { + *at_least_one = true; + break; + } + } + } + + return err; + } + + + template + error_t timeToPZone(mcc_skypoint_c auto const& coords, std::ranges::output_range
auto* res_time) + { + return forEach(_timeToZoneFunc, coords, res_time); + } + + + template + error_t timeFromPZone(mcc_skypoint_c auto const& coords, std::ranges::output_range
auto* res_time) + { + return forEach(_timeFromZoneFunc, coords, res_time); + } + +protected: + typedef std::chrono::nanoseconds duration_t; + + std::vector> _inZoneFunc; + std::vector> _timeToZoneFunc; + std::vector> _timeFromZoneFunc; + + error_t forEach(auto& func_cont, MccSkyPoint const& pt, auto* result) + { + if (result == nullptr) { + return MccPZoneContainerErrorCode::ERROR_NULLPTR; + } + + using res_t = std::decay_t; + using res_elem_t = std::ranges::range_value_t; + + error_t err; + + res_elem_t res_elem; + + size_t res_sz = std::ranges::size(*result); + auto it = result->begin(); + + for (auto& func : func_cont) { + err = func(pt, &res_elem); + if (err) { + return err; + } + + if (it == result->end()) { + std::back_inserter(*result) = res_elem; + it = result->end(); + } else { + *it = std::move(res_elem); + ++it; + } + } + + return MccPZoneContainerErrorCode::ERROR_OK; + } +}; + + +} // namespace mcc::impl diff --git a/mcc_spdlog.h b/mcc_spdlog.h new file mode 100644 index 0000000..6e45f0b --- /dev/null +++ b/mcc_spdlog.h @@ -0,0 +1,198 @@ +#pragma once + + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * IMPLEMENTATION OF LOGGER CLASS * + * (BASING ON THE SPDLOG LIBRARY) * + * * + ****************************************************************************************/ + + + +#include +#include + +#include "mcc_traits.h" + + +namespace mcc::utils +{ + +using namespace std::literals; + +/* SPDLOG-library based advanced single/multithreaded logger */ + +class MccSpdlogLogger +{ +public: + // [year-month-day time.millisecs][log-level]: log-message + constexpr static std::array LOGGER_DEFAULT_FORMAT = {"[%Y-%m-%d %T.%e]"sv, "[%l]"sv, ": "sv, "%v"sv}; + + typedef spdlog::level::level_enum loglevel_t; + + template + MccSpdlogLogger(std::shared_ptr logger, const R& pattern_range = LOGGER_DEFAULT_FORMAT) + : _currentLogPatternRange(), _currentLogPattern(), _loggerSPtr(logger) + { + if (std::distance(pattern_range.begin(), pattern_range.end())) { + std::ranges::copy( + pattern_range | std::views::transform([](const auto& el) { return std::string(el.begin(), el.end()); }), + std::back_inserter(_currentLogPatternRange)); + } else { + std::ranges::copy(LOGGER_DEFAULT_FORMAT | std::views::transform([](const auto& el) { + return std::string(el.begin(), el.end()); + }), + std::back_inserter(_currentLogPatternRange)); + } + + std::ranges::copy(std::views::join(_currentLogPatternRange), std::back_inserter(_currentLogPattern)); + + _loggerSPtr->set_pattern(_currentLogPattern); + } + + + virtual ~MccSpdlogLogger() = default; + + + void setLogLevel(loglevel_t log_level) + { + _loggerSPtr->set_level(log_level); + } + + loglevel_t getLogLevel() const + { + return _loggerSPtr->level(); + } + + void logMessage(loglevel_t level, const std::string& msg) + { + _loggerSPtr->log(level, msg); + } + + // specialized for given level methods + + void logCritical(const std::string& msg) + { + logMessage(spdlog::level::critical, msg); + } + + void logError(const std::string& msg) + { + logMessage(spdlog::level::err, msg); + } + + void logWarn(const std::string& msg) + { + logMessage(spdlog::level::warn, msg); + } + + void logInfo(const std::string& msg) + { + logMessage(spdlog::level::info, msg); + } + + void logDebug(const std::string& msg) + { + logMessage(spdlog::level::debug, msg); + } + + void logTrace(const std::string& msg) + { + logMessage(spdlog::level::trace, msg); + } + + template + void logMessage(spdlog::level::level_enum level, spdlog::format_string_t fmt, ArgTs&&... args) + { + _loggerSPtr->log(level, fmt, std::forward(args)...); + } + + template + void logCritical(spdlog::format_string_t fmt, ArgTs&&... args) + { + _loggerSPtr->log(spdlog::level::critical, fmt, std::forward(args)...); + } + + template + void logError(spdlog::format_string_t fmt, ArgTs&&... args) + { + _loggerSPtr->log(spdlog::level::err, fmt, std::forward(args)...); + } + + template + void logWarn(spdlog::format_string_t fmt, ArgTs&&... args) + { + _loggerSPtr->log(spdlog::level::warn, fmt, std::forward(args)...); + } + + template + void logInfo(spdlog::format_string_t fmt, ArgTs&&... args) + { + _loggerSPtr->log(spdlog::level::info, fmt, std::forward(args)...); + } + + template + void logDebug(spdlog::format_string_t fmt, ArgTs&&... args) + { + _loggerSPtr->log(spdlog::level::debug, fmt, std::forward(args)...); + } + + template + void logTrace(spdlog::format_string_t fmt, ArgTs&&... args) + { + _loggerSPtr->log(spdlog::level::trace, fmt, std::forward(args)...); + } + + + // helper methods + + auto getThreadId() const + { + std::ostringstream st; + st << std::this_thread::get_id(); + return st.str(); + } + + // 'after_idx' is 0-based index! + void addMarkToPatternIdx(const traits::mcc_input_char_range auto& mark, size_t after_idx = 1) + requires(!std::is_pointer_v>) + { + if (!std::distance(mark.begin(), mark.end())) { + return; + } + + auto it = _currentLogPatternRange.begin(); + size_t idx = 0; + while (it != _currentLogPatternRange.end()) { + ++it; + if (idx == after_idx) + break; + + ++idx; + } + + _currentLogPatternRange.emplace(it, mark.begin(), mark.end()); + + _currentLogPattern.clear(); + std::ranges::copy(std::views::join(_currentLogPatternRange), std::back_inserter(_currentLogPattern)); + + _loggerSPtr->set_pattern(_currentLogPattern); + } + + void addMarkToPatternIdx(const char* mark, size_t after_idx = 1) + { + addMarkToPatternIdx(std::string_view{mark}, after_idx); + } + + +protected: + std::list _currentLogPatternRange; + std::string _currentLogPattern; + std::shared_ptr _loggerSPtr; +}; + +} // namespace mcc::utils diff --git a/mcc_telemetry.h b/mcc_telemetry.h new file mode 100644 index 0000000..72491ab --- /dev/null +++ b/mcc_telemetry.h @@ -0,0 +1,369 @@ +#pragma once + + + +/**************************************************************************************** + * * + * MOUNT CONTROL COMPONENTS LIBRARY * + * * + * * + * IMPLEMENTATION OF MOUNT TELEMETRY CLASS * + * * + ****************************************************************************************/ + + +#include +#include "mcc_concepts.h" +#include "mcc_coordinate.h" + +namespace mcc::impl +{ + +enum class MccTelemetryErrorCode : int { + ERROR_OK, + ERROR_NULLPTR, + ERROR_COORD_TRANSFORM, + ERROR_PCM_COMP, + ERROR_HARDWARE_GETSTATE, + ERROR_UPDATE_STOPPED, + ERROR_DATA_TIMEOUT, + ERROR_UNSUPPORTED_COORD_PAIR, + ERROR_UPDATE_LOOP_WAIT +}; + + + +} // namespace mcc::impl + + +namespace std +{ + +template <> +class is_error_code_enum : public true_type +{ +}; + +} // namespace std + + + +namespace mcc::impl +{ + +// error category +struct MccTelemetryCategory : public std::error_category { + MccTelemetryCategory() : std::error_category() {} + + const char* name() const noexcept + { + return "MCC-TELEMETRY"; + } + + std::string message(int ec) const + { + MccTelemetryErrorCode err = static_cast(ec); + + switch (err) { + case MccTelemetryErrorCode::ERROR_OK: + return "OK"; + case MccTelemetryErrorCode::ERROR_NULLPTR: + return "nullptr input argument"; + case MccTelemetryErrorCode::ERROR_COORD_TRANSFORM: + return "coordinate transformation error"; + case MccTelemetryErrorCode::ERROR_PCM_COMP: + return "PCM computation error"; + case MccTelemetryErrorCode::ERROR_HARDWARE_GETSTATE: + return "cannot get hardware state"; + case MccTelemetryErrorCode::ERROR_UPDATE_STOPPED: + return "telemetry update was stopped"; + case MccTelemetryErrorCode::ERROR_DATA_TIMEOUT: + return "a timeout occured while waiting for new data"; + case MccTelemetryErrorCode::ERROR_UNSUPPORTED_COORD_PAIR: + return "unsupported coordinate pair"; + case MccTelemetryErrorCode::ERROR_UPDATE_LOOP_WAIT: + return "a timeout occured while waiting to exit the update loop"; + default: + return "UNKNOWN"; + } + } + + static const MccTelemetryCategory& get() + { + static const MccTelemetryCategory constInst; + return constInst; + } +}; + + +inline std::error_code make_error_code(MccTelemetryErrorCode ec) +{ + return std::error_code(static_cast(ec), MccTelemetryCategory::get()); +} + + + +template +class MccTelemetry +{ +public: + typedef HARDWARE_T hardware_t; + + typedef std::error_code error_t; + + + struct telemetry_data_t { + MccSkyPoint targetPos{}; + + MccSkyPoint mountPos{}; + + typename HARDWARE_T::hardware_state_t hwState{}; + + struct { + double pcmX{}, pcmY{}; + } pcmCorrection{}; + }; + + static constexpr std::chrono::milliseconds _defaultTelemetryDataTimeout{500}; + + /* + MccTelemetry(HARDWARE_T* hardware, mcc_pcm_c auto* pcm) : _hardware(hardware) + { + _updateFunc = [pcm, this](telemetry_data_t* tdata) { + if (tdata == nullptr) { + return MccTelemetryErrorCode::ERROR_NULLPTR; + } + + // get hardware state (coordinates, speeds and so on) + auto hw_err = _hardware->hardwareGetState(&(tdata->hwState)); + if (hw_err) { + return mcc_deduced_err(hw_err, MccTelemetryErrorCode::ERROR_HARDWARE_GETSTATE); + } + + // compute PCM corrections and observed (corrected for PCM) mount coordinates + auto pcm_err = pcm->computePCM(tdata->hwState.XY, &(tdata->pcmCorrection), &(tdata->mountPos)); + + if (pcm_err) { + return mcc_deduced_err(pcm_err, MccTelemetryErrorCode::ERROR_PCM_COMP); + } + + return MccTelemetryErrorCode::ERROR_OK; + }; + + + _updatingStopSource = std::stop_source{}; + + _dataUpdatingRequested->clear(); + _dataUpdatingStart->clear(); + + // start thread for data updating + _updatingFuture = std::async( + std::launch::async, + [this](std::stop_token stoken, telemetry_data_t* tdata) { + while (!stoken.stop_requested()) { + _dataUpdatingRequested->wait(false); + + if (!stoken.stop_requested()) { + std::lock_guard lock{*_timeoutMutex}; + + _dataUpdatingStart->test_and_set(); + _dataUpdatingStart->notify_all(); + + _lastUpdateError = _updateFunc(tdata); + + _dataUpdatingStart->clear(); + _dataUpdatingRequested->clear(); + } + } + }, + _updatingStopSource.get_token(), _tdataPtr); + } +*/ + + MccTelemetry(HARDWARE_T* hardware, mcc_pcm_c auto* pcm) + { + _updatingStopSource = std::stop_source{}; + + _dataUpdatingRequested->clear(); + _dataUpdatingStart->clear(); + + // start thread for data updating + _updatingFuture = std::async( + std::launch::async, + [this](std::stop_token stoken, HARDWARE_T* hw, auto* pcm_ptr) { + while (!stoken.stop_requested()) { + _dataUpdatingRequested->wait(false); + + if (!stoken.stop_requested()) { + std::lock_guard lock{*_timeoutMutex}; + + _dataUpdatingStart->test_and_set(); + _dataUpdatingStart->notify_all(); + + if (_tdataPtr != nullptr && hw && pcm_ptr) { + _lastUpdateError = MccTelemetryErrorCode::ERROR_OK; + + // get hardware state (coordinates, speeds and so on) + auto hw_err = hw->hardwareGetState(&_tdataPtr->hwState); + if (hw_err) { + _lastUpdateError = + mcc_deduced_err(hw_err, MccTelemetryErrorCode::ERROR_HARDWARE_GETSTATE); + } else { + // compute PCM corrections and observed (corrected for PCM) mount coordinates + auto pcm_err = pcm_ptr->computePCM(_tdataPtr->hwState.XY, &_tdataPtr->pcmCorrection, + &_tdataPtr->mountPos); + + if (!pcm_err) { + // set target coordinates + if (_enteredTargetPos.pairKind() == MccCoordPairKind::COORDS_KIND_XY) { + // hardware coordinates + MccGenXY xy; + auto ccte_err = _enteredTargetPos.toAtSameEpoch(xy); + + if (!ccte_err) { + decltype(_tdataPtr->pcmCorrection) pcm_corr; + + pcm_err = pcm_ptr->computePCM(xy, &pcm_corr, &_tdataPtr->targetPos); + if (pcm_err) { + _lastUpdateError = + mcc_deduced_err(pcm_err, MccTelemetryErrorCode::ERROR_PCM_COMP); + } + + } else { + _lastUpdateError = + mcc_deduced_err(ccte_err, MccTelemetryErrorCode::ERROR_COORD_TRANSFORM); + } + } else { // observed, apparent or ICRS + _tdataPtr->targetPos = _enteredTargetPos; + } + + } else { + _lastUpdateError = mcc_deduced_err(pcm_err, MccTelemetryErrorCode::ERROR_PCM_COMP); + } + } + + } else { + _lastUpdateError = MccTelemetryErrorCode::ERROR_NULLPTR; + } + + _dataUpdatingStart->clear(); + _dataUpdatingRequested->clear(); + } + } + }, + _updatingStopSource.get_token(), hardware, pcm); + } + + MccTelemetry(MccTelemetry&&) = default; + MccTelemetry& operator=(MccTelemetry&&) = default; + + MccTelemetry(const MccTelemetry&) = delete; + MccTelemetry& operator=(const MccTelemetry&) = delete; + + + ~MccTelemetry() + { + _tdataPtr = nullptr; + + _updatingStopSource.request_stop(); + + // trigger updating and exit from the inner loop of the hardware polling thread (see constructor) + _dataUpdatingRequested->test_and_set(); + // _dataUpdatingRequested->notify_one(); + _dataUpdatingRequested->notify_all(); + + if (_updatingFuture.valid()) { + // try to exit correctly + _updatingFuture.wait_for(std::chrono::seconds(1)); + } + } + + error_t setTarget(mcc_skypoint_c auto const& sp) + { + _enteredTargetPos = sp; + + return MccTelemetryErrorCode::ERROR_OK; + } + + + // + // blocks the current thread until telemetry data is received. + // the maximum blocking time is equal to the set timeout (see setTelemetryDataTimeout method) + // + error_t telemetryData(telemetry_data_t* tdata) + { + std::lock_guard lock{*_updateMutex}; + + _lastUpdateError = MccTelemetryErrorCode::ERROR_OK; + + _tdataPtr = tdata; + + // trigger updating + _dataUpdatingRequested->test_and_set(); + _dataUpdatingRequested->notify_one(); + + // wait for updating start + _dataUpdatingStart->wait(false); + if (_timeoutMutex->try_lock_for(_telemetryDataTimeout->load())) { + _timeoutMutex->unlock(); + } else { + _lastUpdateError = MccTelemetryErrorCode::ERROR_DATA_TIMEOUT; + } + + return _lastUpdateError; + } + + // + // Set a timeout for the telemetry receiving process + // + void setTelemetryDataTimeout(traits::mcc_time_duration_c auto const& timeout) + { + if constexpr (std::floating_point) { + if (utils::isEqual(timeout.count(), 0.0) || timeout.count() < 0.0) { + return; + } + } else { + if (timeout.count() <= 0.0) { + return; + } + } + + *_telemetryDataTimeout = std::chrono::duration_cast(timeout); + } + + template + DT getTelemetryDataTimeout() const + { + return std::chrono::duration_cast
(_telemetryDataTimeout->load()); + } + + std::chrono::milliseconds getTelemetryDataTimeout() const + { + return getTelemetryDataTimeout(); + } + +private: + // HARDWARE_T* _hardware{nullptr}; + MccSkyPoint _enteredTargetPos{}; + + // std::function _updateFunc{}; + telemetry_data_t* _tdataPtr; + + std::unique_ptr _dataUpdatingRequested{new std::atomic_flag{}}; + std::unique_ptr _dataUpdatingStart{new std::atomic_flag{}}; + std::unique_ptr _timeoutMutex{new std::timed_mutex()}; + + std::stop_source _updatingStopSource{}; + + error_t _lastUpdateError{MccTelemetryErrorCode::ERROR_OK}; + + std::unique_ptr> _telemetryDataTimeout{ + new std::atomic{_defaultTelemetryDataTimeout}}; + + std::unique_ptr _updateMutex{new std::mutex{}}; + + std::future _updatingFuture{}; +}; + + +} // namespace mcc::impl diff --git a/mcc_traits.h b/mcc_traits.h new file mode 100644 index 0000000..0df7363 --- /dev/null +++ b/mcc_traits.h @@ -0,0 +1,248 @@ +#pragma once + +#include +#include +#include + +namespace mcc::traits +{ + + +template +static constexpr size_t mcc_range_size(const R& r) +{ + if constexpr (std::ranges::sized_range) { + return r.size(); + } else { + return std::ranges::distance(r.begin(), r.end()); + } +} + + +template +concept mcc_char_view = std::ranges::view && std::same_as, char>; + + +// range of char/const char +template +concept mcc_char_range = std::ranges::range && std::same_as>, CharT>; + + +// input range of char/const char +template +concept mcc_input_char_range = + std::ranges::input_range && std::is_same_v>, CharT>; + + +// output range of char/const char +template +concept mcc_output_char_range = + std::ranges::output_range && std::same_as>, CharT>; + + +template +concept mcc_view_or_output_char_range = mcc_char_view || mcc_output_char_range; + + +template +concept mcc_range_of_char_range = std::ranges::range && mcc_char_range>; + +template +concept mcc_range_of_input_char_range = + std::ranges::range && traits::mcc_input_char_range>; + + +template +concept mcc_range_of_output_char_range = + std::ranges::range && traits::mcc_output_char_range>; + + + +// https://stackoverflow.com/questions/72430369/how-to-check-that-a-type-is-formattable-using-type-traits-concepts) +template +concept mcc_formattable = + requires(T v, std::format_context ctx) { std::formatter>().format(v, ctx); }; + + +// from https://stackoverflow.com/questions/74383254/concept-that-models-only-the-stdchrono-duration-types +template +concept mcc_time_duration_c = requires { + [](std::type_identity>) { + + }(std::type_identity>()); +}; + + +template +concept mcc_systime_c = requires { + [](std::type_identity>) {}(std::type_identity>()); +}; + + +template +concept mcc_time_duration_output_range_c = + std::ranges::output_range> && mcc_time_duration_c>; + +/* a callable concept and its signature traits */ + +template +concept mcc_is_callable = std::is_function_v || (std::is_object_v && requires(T) { &T::operator(); }); + +template +concept mcc_callable_c = std::is_function_v || (std::is_object_v && requires(T) { &T::operator(); }); + + +// helper classes for callable signature deducing +template +struct mcc_func_traits_helper_t; + +template +struct mcc_func_traits_helper_t { + using ret_t = R; + using args_t = std::tuple<>; + using arg1_t = void; + static constexpr size_t arity = 0; +}; + +template +struct mcc_func_traits_helper_t { + using ret_t = R; + using args_t = std::tuple; + using arg1_t = Arg; + static constexpr size_t arity = sizeof...(Args) + 1; +}; + +template +struct mcc_func_traits { + // use of an empty struct here to match std::invoke_result behaivior (at least of GCC) +}; + +template +struct mcc_func_traits : mcc_func_traits_helper_t { +}; + +template +struct mcc_func_traits : mcc_func_traits_helper_t { +}; + +template +struct mcc_func_traits : mcc_func_traits_helper_t { +}; + +template +struct mcc_func_traits : mcc_func_traits_helper_t { +}; + +template + requires mcc_is_callable +struct mcc_func_traits : mcc_func_traits { +}; + +// reference/const ref and rvalue helpers +template +struct mcc_func_traits : mcc_func_traits { +}; + +template +struct mcc_func_traits : mcc_func_traits { +}; + +template +struct mcc_func_traits : mcc_func_traits { +}; + +// type of the returned value +template +using mcc_retval_t = typename mcc_func_traits::ret_t; + +// type of the first argument of callable +template +using mcc_func_arg1_t = typename mcc_func_traits::arg1_t; + +// type of the N-th argument of callable +// NOTE: starts from 1 not from 0!!! +template +using mcc_func_argN_t = std::conditional_t= mcc_func_traits::arity, + std::tuple_element_t::args_t>, + void>; + + +// std::array +template +concept mcc_array_c = requires(T t) { + [](std::array) { + + }(t); +}; + + +// non-const lvalue reference, constructible from CtorArgTs (an output argument of function) +template +concept mcc_output_arg_c = !std::is_const_v> && std::is_lvalue_reference_v && + std::constructible_from, CtorArgTs...>; + + + +// std::tuple or std::pair +template +concept mcc_tuple_c = requires { + requires requires { + [](std::type_identity>) {}(std::type_identity>()); + } || requires { + [](std::type_identity>) { + }(std::type_identity>()); + }; +}; + + +template +concept mcc_nonconst_lvref = std::is_lvalue_reference_v && !std::is_const_v>; + + +template +concept mcc_error_c = std::convertible_to || requires(const T t) { + { t.operator bool() }; +}; + +namespace details +{ + +// compile-time hash for type +// (from https://stackoverflow.com/questions/56292104/hashing-types-at-compile-time-in-c17-c2a) +// WARNING: it does not work for unnamed struct!!! +template +static consteval size_t Hash() +{ + size_t result{}; + +#ifdef _MSC_VER + for (const auto& c : __FUNCSIG__) +#else // GCC and clang + for (const auto& c : __PRETTY_FUNCTION__) +#endif + (result ^= c) <<= 1; + + return result; +} + +} // namespace details + +template +static constexpr size_t mcc_type_hash = details::Hash(); + +static constexpr size_t mcc_hash_combine(size_t lhs, size_t rhs) +{ + constexpr size_t v_const = sizeof(size_t) >= 8 ? 0x517cc1b727220a95 : 0x9e3779b9; + + lhs ^= rhs + v_const + (lhs << 6) + (lhs >> 2); + + return lhs; +} + +template +static constexpr size_t mcc_type_pair_hash() +{ + return mcc_hash_combine(mcc_type_hash, mcc_type_hash); +} + +} // namespace mcc::traits diff --git a/mcc_utils.h b/mcc_utils.h new file mode 100644 index 0000000..8c7cdde --- /dev/null +++ b/mcc_utils.h @@ -0,0 +1,750 @@ +#pragma once + +#include +#include +#include +#include +#include +#include +#include +#include +#include "mcc_traits.h" + +namespace mcc::utils +{ + +static const std::regex decimalNumberRx{" *[-+]?([0-9]*[.])?[0-9]+([eE][-+]?[0-9]+)? *"}; +static const std::regex sexagesimalReprRx{" *[-+]?[0-9]{1,2}:[0-9]{1,2}:([0-9]{0,2}[.])?[0-9]+ *"}; + + +constexpr static bool isEqual(std::floating_point auto const& v1, std::floating_point auto const& v2) +{ + constexpr auto eps = std::numeric_limits>::epsilon(); + + return std::fabs(v1 - v2) <= eps * std::fmax(std::fabs(v1), std::fabs(v2)); +} + +enum class TrimType { TRIM_LEFT, TRIM_RIGHT, TRIM_BOTH }; + +template +constexpr static std::string_view trimSpaces(R&& r, TrimType type = TrimType::TRIM_BOTH) + requires std::same_as>> +{ + auto is_space = [](const auto& ch) { return ch == ' '; }; + + auto end = std::forward(r).end(); + + auto f1 = std::forward(r).begin(); + + if (type != TrimType::TRIM_RIGHT) { + // look for the first non-space symbol + f1 = std::ranges::find_if_not(std::forward(r), is_space); + if (f1 == end) { // all are spaces! + return std::string_view(); + } + } + + auto f2 = end; + + if (type != TrimType::TRIM_LEFT) { + auto f3 = f1; + + do { + f2 = std::ranges::find_if(++f3, end, is_space); + if (f2 == end) + break; + f3 = std::ranges::find_if_not(f2 + 1, end, is_space); + } while (f3 != end); + } + + return std::string_view(f1, f2); +} + +constexpr static std::string_view trimSpaces(const char* r, TrimType type = TrimType::TRIM_BOTH) +{ + return trimSpaces(std::string_view(r), type); +} + +template +std::optional numFromStr(R&& r) + requires((std::integral || std::floating_point) && + std::same_as>>) +{ + T val; + const char* end_ptr = &*r.end(); + + if constexpr (std::integral) { + auto cvt_res = std::from_chars(&*r.begin(), &*r.end(), val); + if (cvt_res.ec != std::errc()) { + return std::nullopt; + } else if (cvt_res.ptr != end_ptr) { + return std::nullopt; + } + } else { +#ifdef _LIBCPP_VERSION // clang's libc++ does not have floating-point overloads for std::from_chars + std::string s{str.begin(), str.end()}; + size_t pos; + + try { + if constexpr (std::same_as) { + val = std::stof(s, &pos); + } else if constexpr (std::same_as) { + val = std::stod(s, &pos); + } else { + val = std::stold(s, &pos); + } + } catch (...) { + return std::nullopt; + } + + if (pos != s.size()) { + return std::nullopt; + } +#else + auto cvt_res = std::from_chars(&*r.begin(), &*r.end(), val); + + if (cvt_res.ec != std::errc()) { + return std::nullopt; + } else if (cvt_res.ptr != end_ptr) { + return std::nullopt; + } +#endif + } + + return val; +} + +template +static std::optional parsAngleString(R&& r, bool hms = false) + requires std::same_as>> +{ + auto str = trimSpaces(std::forward(r)); + + bool ok = std::regex_match(str.begin(), str.end(), decimalNumberRx); + + if (ok) { + return numFromStr(str); + } + + ok = std::regex_match(str.begin(), str.end(), sexagesimalReprRx); + + if (ok) { + auto str = trimSpaces(std::forward(r)); + auto parts = std::views::split(str, std::string_view(":")); + + double val; + + double p1 = numFromStr(*parts.begin()).value(); + val = std::abs(p1); + double dv = 60.0; + for (auto const& v : parts | std::views::drop(1)) { + val += numFromStr(v).value() / dv; + dv *= 60.0; + } + // val += numFromStr(parts[1]) / 60.0; + // val += numFromStr(parts[2]) / 3600.0; + if (p1 < 0) { + val = -val; + } + + if (hms) { + val *= 15.0; + } + + return val; + } + + + return std::nullopt; +} + +[[maybe_unused]] static std::optional parsAngleString(const char* s, bool hms = false) +{ + return parsAngleString(std::span{s, std::strlen(s)}, hms); +} + + +static constexpr auto deg2radCoeff = std::numbers::pi / 180.0; + +// radians to degrees +template +static double rad2deg(double ang) +{ + auto r = ang / deg2radCoeff; + + if constexpr (NORM) { + return std::fmod(r, 360.0); + } else { + return r; + } +} + + +template R, bool NORM = false> +static R rad2deg_str(double ang, int prec = 6) +{ + R res; + + std::string fmt = "{:0." + std::to_string(prec) + "f}"; + + auto degs = rad2deg(ang); + + std::vformat_to(std::back_inserter(res), {fmt.begin(), fmt.end()}, std::make_format_args(degs)); + + return res; +} + +template +static std::string rad2deg_str(double ang, int prec = 6) +{ + return rad2deg_str(ang, prec); +} + + +template R, bool NORM = false> +static R rad2deg_str(double ang1, double ang2, std::string_view delim = ",", int prec1 = 6, int prec2 = 6) +{ + R res = rad2deg_str(ang1, prec1); + + R r = rad2deg_str(ang2, prec2); + + std::ranges::copy(delim, std::back_inserter(res)); + std::ranges::copy(r, std::back_inserter(res)); + + return res; +} + +template +static std::string rad2deg_str(double ang1, double ang2, std::string_view delim = ",", int prec1 = 6, int prec2 = 6) +{ + return rad2deg_str(ang1, ang2, delim, prec1, prec2); +} + +// radians to sexagesimal +template R, bool NORM = false> +static R rad2sxg(double ang, bool hms = false, int prec = 2) +{ + R res; + + if (!std::isfinite(ang)) { + std::vformat_to(std::back_inserter(res), "{}", std::make_format_args(ang)); + return res; + } + + std::string fmt = "{:02.0f}:{:02.0f}:{:0" + std::to_string(prec + 3) + "." + std::to_string(prec) + "f}"; + // std::string fmt = "{:02.0f}:{:02.0f}:{:02." + std::to_string(prec) + "f}"; + + auto degs = rad2deg(std::abs(ang)); + if (hms) { + degs /= 15.0; + } + + auto term = 10.0; + for (int i = 1; i < prec; ++i) { + term *= 10.0; + } + + // round to given precision of arcseconds/seconds + degs = std::round(degs * 3600.0 * term) / term / 3600.0; + + + auto d = std::trunc(degs); + auto s = (degs - d) * 60.0; + auto m = std::trunc(s); + + s = (s - m) * 60.0; + // round to given precision + s = std::round(s * term) / term; + if (isEqual(s, 60.0)) { + m += 1.0; + s = 0.0; + if (isEqual(m, 60.0)) { + d += 1.0; + m = 0.0; + } + } + + if (ang < 0) { + if (!isEqual(d, 0.0) || !isEqual(m, 0.0) || !isEqual(s, 0.0)) { + std::ranges::copy(std::string_view("-"), std::back_inserter(res)); + } + } + + std::vformat_to(std::back_inserter(res), std::string_view{fmt.begin(), fmt.end()}, std::make_format_args(d, m, s)); + + return res; +} + +template +static std::string rad2sxg(double ang, bool hms = false, int prec = 2) +{ + return rad2sxg(ang, hms, prec); +} + + +template R, bool NORM = false> +static R RADEC_rad2sxg(double ra, double dec, std::string_view delim = ",", int ra_prec = 2, int dec_prec = 1) +{ + R res = rad2sxg(ra, true, ra_prec); + + R r = rad2sxg(dec, false, dec_prec); + + std::ranges::copy(delim, std::back_inserter(res)); + std::ranges::copy(r, std::back_inserter(res)); + + return res; +} + +template +static std::string RADEC_rad2sxg(double ra, double dec, std::string_view delim = ",", int ra_prec = 2, int dec_prec = 1) +{ + return RADEC_rad2sxg(ra, dec, delim, ra_prec, dec_prec); +} + + +template R, bool NORM = false> +static R AZZD_rad2sxg(double az, double zd, std::string_view delim = ",", int az_prec = 2, int zd_prec = 1) +{ + R res = rad2sxg(az, false, az_prec); + + R r = rad2sxg(zd, false, zd_prec); + + std::ranges::copy(delim, std::back_inserter(res)); + std::ranges::copy(r, std::back_inserter(res)); + + return res; +} + +template +static std::string AZZD_rad2sxg(double az, double zd, std::string_view delim = ",", int az_prec = 2, int zd_prec = 1) +{ + return AZZD_rad2sxg(az, zd, delim, az_prec, zd_prec); +} + + +// string to pair of angles +// " 12.3453467,102.4345346" +// "12:43:23.423, 102:43:12.124" +// " 12.3453467, 102:43:12.124 " +template +std::pair parseAnglePair(R&& str, bool hms1 = false, bool hms2 = false, std::string_view delim = ",") +{ + std::pair res{std::numeric_limits::quiet_NaN(), std::numeric_limits::quiet_NaN()}; + auto found1 = std::ranges::search(std::forward(str), delim); + + if (found1.empty()) { + return res; + } + + std::string s1, s2; + std::ranges::copy(str.begin(), found1.begin(), std::back_inserter(s1)); + + auto rem_len = std::distance(found1.end(), str.end()); + if (!rem_len) { + return res; + } + + auto found2 = std::ranges::search(found1.end(), str.end(), delim.begin(), delim.end()); + if (found2.empty()) { + std::ranges::copy(found1.end(), str.end(), std::back_inserter(s2)); + } else { + std::ranges::copy(found1.end(), found2.end(), std::back_inserter(s2)); + } + + auto vo1 = parsAngleString(s1, hms1); + if (vo1) { + auto vo2 = parsAngleString(s2, hms2); + if (vo2) { + res = {vo1.value(), vo2.value()}; + } + } + + return res; +} + + +template +static constexpr size_t FNV1aHash(const R& r) +{ + static_assert(sizeof(size_t) == 8 || sizeof(size_t) == 4, "ONLY FOR 32 or 64-bit size_t!!!"); + + size_t hash = 0, prime = 0; + if constexpr (sizeof(size_t) == 8) { // 64-bit + prime = 1099511628211UL; + hash = 14695981039346656037UL; + } else if constexpr (sizeof(size_t) == 4) { // 32-bit + prime = 16777619; + hash = 2166136261; + } + + for (const char& ch : r) { + hash ^= ch; + hash *= prime; + } + + return hash; +} + +static constexpr size_t FNV1aHash(std::forward_iterator auto begin, std::sentinel_for auto end) + requires std::same_as>, char> +{ + static_assert(sizeof(size_t) == 8 || sizeof(size_t) == 4, "ONLY FOR 32 or 64-bit size_t!!!"); + + size_t hash = 0, prime = 0; + if constexpr (sizeof(size_t) == 8) { // 64-bit + prime = 1099511628211UL; + hash = 14695981039346656037UL; + } else if constexpr (sizeof(size_t) == 4) { // 32-bit + prime = 16777619; + hash = 2166136261; + } + + for (auto it = begin; it != end; ++it) { + hash ^= *it; + hash *= prime; + } + + return hash; +} + + +class MccSimpleDeserializer +{ +public: + static constexpr std::string_view RANGE_DELIM_SEQ = ","; + + MccSimpleDeserializer() : _rangeDelim(RANGE_DELIM_SEQ) {} + + template + MccSimpleDeserializer(R&& r) : MccSimpleDeserializer() + { + setRangeDelim(std::forward(r)); + } + + template + MccSimpleDeserializer& setRangeDelim(R&& r) + { + if (std::ranges::size(std::forward(r))) { + _rangeDelim.clear(); + std::ranges::copy(std::forward(r), std::back_inserter(_rangeDelim)); + } + + return *this; + } + + template + R getRangeDelim() const + { + R r; + + std::ranges::copy(_rangeDelim, std::back_inserter(r)); + + return r; + } + + std::string getRangeDelim() const + { + return getRangeDelim(); + } + + template + std::error_code operator()(IR&& bytes, VT& value) const + { + std::error_code ret{}; + + if constexpr (std::is_arithmetic_v) { + auto v = mcc::utils::numFromStr(trimSpaces(bytes)); + if (!v.has_value()) { + return std::make_error_code(std::errc::invalid_argument); + } + + value = v.value(); + } else if constexpr (mcc::traits::mcc_output_char_range) { + VT r; + if constexpr (traits::mcc_array_c) { + size_t N = + std::ranges::size(r) <= std::ranges::size(bytes) ? std::ranges::size(r) : std::ranges::size(bytes); + + for (size_t i = 0; i < N; ++i) { + r[i] = bytes[i]; + } + if (std::ranges::size(r) > N) { + for (size_t i = N; i < std::ranges::size(r); ++i) { + r[i] = '\0'; + } + } + } else { + std::ranges::copy(bytes, std::back_inserter(r)); + } + value = r; + } else if constexpr (std::ranges::range) { + using el_t = std::ranges::range_value_t; + + if constexpr (std::is_reference_v || std::is_const_v) { // no reference or constants allowed + return std::make_error_code(std::errc::invalid_argument); + } + + VT r; + el_t elem; + size_t i = 0; + + if (trimSpaces(bytes).size()) { + auto els = std::views::split(bytes, _rangeDelim); + + for (auto const& el : els) { + ret = (*this)(std::string_view(el), elem); + if (!ret) { + if constexpr (traits::mcc_array_c) { + if (i < std::ranges::size(r)) { + r[i] = elem; + } + ++i; + } else { + std::back_inserter(r) = elem; + } + } else { + return std::make_error_code(std::errc::invalid_argument); + } + } + } + + value = r; + } else if constexpr (mcc::traits::mcc_time_duration_c) { + typename VT::rep vd; + + ret = (*this)(trimSpaces(bytes), vd); + if (!ret) { + value = VT{vd}; + } + } else { + ret = std::make_error_code(std::errc::invalid_argument); + } + + return ret; + } + +protected: + std::string _rangeDelim; +}; + + +/* key-value pair holder */ + +// to follow std::variant requirements (not references, not array, not void) +template +concept variant_valid_type_c = requires { !std::is_array_v && !std::is_void_v && !std::is_reference_v; }; + + +template +concept keyvalue_record_c = requires(T t) { + requires std::same_as; + requires variant_valid_type_c; +}; + + +template +concept keyvalue_desc_c = requires(T t) { [](std::tuple) {}(t); }; + + +template +class KeyValueHolder +{ +public: + static constexpr std::string_view COMMENT_SEQ{"#"}; + static constexpr std::string_view KEY_VALUE_DELIM{"="}; + static constexpr std::string_view VALUE_ARRAY_DELIM{","}; + + inline static auto defaultDeserializeFunc = [](this auto&& self, std::string_view str, VT& value) { + std::error_code ret{}; + + if constexpr (std::is_arithmetic_v) { + auto v = mcc::utils::numFromStr(trimSpaces(str)); + if (!v.has_value()) { + return std::make_error_code(std::errc::invalid_argument); + } + + value = v.value(); + } else if constexpr (mcc::traits::mcc_output_char_range) { + VT r; + std::ranges::copy(str, std::back_inserter(r)); + value = r; + } else if constexpr (std::ranges::range) { + using el_t = std::ranges::range_value_t; + + if constexpr (std::is_reference_v || std::is_const_v) { // no reference or constants allowed + return std::make_error_code(std::errc::invalid_argument); + } + + VT r; + el_t elem; + + auto els = std::views::split(str, VALUE_ARRAY_DELIM); + + for (auto const& el : els) { + ret = std::forward(self)(std::string_view(el), elem); + if (!ret) { + std::back_inserter(r) = elem; + } else { + return std::make_error_code(std::errc::invalid_argument); + } + } + + value = r; + } else if constexpr (mcc::traits::mcc_time_duration_c) { + typename VT::rep vd; + + ret = std::forward(self)(trimSpaces(str), vd); + if (!ret) { + value = VT{vd}; + } + } else { + ret = std::make_error_code(std::errc::invalid_argument); + } + + return ret; + }; + + KeyValueHolder(DESCR_T desc) : _keyValue(desc) + { + [this](std::index_sequence) { + ((_hashes[I] = FNV1aHash(std::get(_keyValue).key)), ...); + }(std::make_index_sequence>()); + } + + template + std::expected getValue(std::string_view key) const + { + T v; + auto err = forKey(key, [&v](const VT& val) { + if constexpr (std::convertible_to) { + v = val; + return std::error_code(); + } else { + return std::make_error_code(std::errc::invalid_argument); + } + }); + + if (err) { + return std::unexpected(err); + } else { + return v; + } + } + + template + std::error_code setValue(std::string_view key, const T& value) + { + return forKey(key, [value](VT& val) { + if constexpr (std::convertible_to) { + val = value; + return std::error_code(); + } else if constexpr (std::constructible_from) { + val = VT(value); + return std::error_code(); + } else { + return std::make_error_code(std::errc::invalid_argument); + } + }); + } + + + template + std::error_code fromCharRange(const R& buffer, RecDelimT rec_delim = std::string_view("\n")) + { + // return fromCharRange(buffer, KeyValueHolder::defaultDeserializeFunc, std::move(rec_delim)); + return fromCharRange(buffer, MccSimpleDeserializer{}.setRangeDelim(VALUE_ARRAY_DELIM), std::move(rec_delim)); + } + + template + std::error_code fromCharRange(const R& buffer, + DeserFuncT&& deser_func, + RecDelimT rec_delim = std::string_view("\n")) + { + // static_assert(mcc::traits::mcc_callable_c>, "!!!!!!!"); + + if constexpr (std::is_array_v>) { // char*, const char* + if constexpr (std::is_array_v>) { + return fromCharRange(std::string_view{buffer}, std::forward(deser_func), + std::string_view(rec_delim)); + } else { + return fromCharRange(std::string_view{buffer}, std::forward(deser_func), + std::move(rec_delim)); + } + } else { + if constexpr (std::is_array_v>) { + return fromCharRange(buffer, std::forward(deser_func), std::string_view(rec_delim)); + } + } + + + std::error_code ec{}; + std::string_view rec, key, value; + + + auto recs = std::views::split(buffer, std::move(rec_delim)); + for (auto const& el : recs) { + rec = mcc::utils::trimSpaces(el, TrimType::TRIM_LEFT); + + if (rec.size()) { + auto found = std::ranges::search(rec, COMMENT_SEQ); + if (found.begin() != rec.end()) { // there was the comment sequence in record + rec = std::string_view(rec.begin(), found.begin()); + } + + if (rec.size()) { + found = std::ranges::search(rec, KEY_VALUE_DELIM); + if (found.begin() != rec.begin()) { // ignore an empty key + key = trimSpaces(std::string_view(rec.begin(), found.begin()), TrimType::TRIM_RIGHT); + value = std::string_view(found.end(), rec.end()); + + ec = forKey(key, [value, &deser_func](VT& v) { return deser_func(value, v); }); + } + } // just comment string starting from the beginning, just skip it (no error) + + } // empty record, just skip it (no error) + + if (ec) { + break; + } + } + + return ec; + } + +protected: + DESCR_T _keyValue; + + std::array> _hashes; + + + // + // NOTE: deduced this is needed here to use "forKey" method in getter and setter (const and non-const contexts)!!! + // + + std::error_code forKey(this auto&& self, std::string_view key, auto&& func) + { + return std::forward(self).template forHash<0>(FNV1aHash(key), + std::forward(func)); + } + + + template + std::error_code forHash(this auto&& self, size_t hash, auto&& func) + { + if constexpr (I < std::tuple_size_v) { + if (hash == std::forward(self)._hashes[I]) { + return std::forward(func)( + std::get(std::forward(self)._keyValue).value); + } else { + return std::forward(self).template forHash(hash, + std::forward(func)); + } + } + + return std::make_error_code(std::errc::argument_out_of_domain); + } +}; + +} // namespace mcc::utils diff --git a/tests/mcc_coord_test.cpp b/tests/mcc_coord_test.cpp new file mode 100644 index 0000000..c1b33f3 --- /dev/null +++ b/tests/mcc_coord_test.cpp @@ -0,0 +1,86 @@ +#include + +// #include +#include + + +using namespace mcc::impl; + +typedef MccGenericSkyPoint skypt_t; + + +static skypt_t::ccte_t::engine_state_t saoras{.meteo{.temperature = 0.0, .humidity = 0.5, .pressure = 1010.0}, + .wavelength = 0.5, + .lat = 43.646711_degs, + .lon = 41.440732_degs, + .elev = 2100.0}; + +// skypt_t::cctEngine.setStateERFA(saoras); + +static_assert(mcc::mcc_angle_c, "!!!!!!!!!!!!"); + +int main() +{ + skypt_t::cctEngine.setStateERFA(saoras); + + skypt_t pt; + MccSkyRADEC_ICRS icrs(0.0, 70.0_degs); + + pt = icrs; + + MccSkyRADEC_OBS radec_obs{0.0, 0.0}; + MccSkyRADEC_APP radec_app; + MccSkyAZALT azalt{0, 0}; + MccSkyAZZD azzd{0, 0}; + MccSkyHADEC_OBS hadec_obs; + MccAngle eo, lst; + + skypt_t::cctEngine.equationOrigins(radec_obs.epoch(), &eo); + skypt_t::cctEngine.apparentSideralTime(radec_obs.epoch(), &lst, true); + std::cout << "EO = " << eo.sexagesimal(true) << "\n"; + std::cout << "LST = " << lst.sexagesimal(true) << "\n\n"; + + pt.to(radec_obs, azalt, azzd, radec_app); + + std::cout << "FROM ICRS TO OBSERVED:\n"; + std::cout << "RA_ICRS = " << icrs.x().sexagesimal(true) << "\n"; + std::cout << "DEC_ICRS = " << icrs.y().sexagesimal() << "\n"; + std::cout << "OBS COORD EPOCH: " << radec_obs.epoch().UTC() << "\n"; + std::cout << "RA_OBS = " << radec_obs.x().sexagesimal(true) << "\n"; + std::cout << "DEC_OBS = " << radec_obs.y().sexagesimal() << "\n"; + std::cout << "AZ = " << azalt.x().sexagesimal() << "\n"; + std::cout << "ALT = " << azalt.y().sexagesimal() << "\n"; + std::cout << "ZD = " << azzd.y().sexagesimal() << "\n"; + std::cout << "RA_APP = " << radec_app.x().sexagesimal(true) << "\n"; + std::cout << "DEC_APP = " << radec_app.y().sexagesimal() << "\n"; + + + // radec_obs = {10.2387983_degs, "43:21:34.5465"_dms}; + icrs.setX(111.0_degs), icrs.setY(111.0_degs); + azzd.setX(111.0_degs), azzd.setY(111.0_degs); + azalt.setX(111.0_degs), azalt.setY(111.0_degs); + hadec_obs.setX(111.0_degs), hadec_obs.setY(111.0_degs); + + pt = radec_obs; + pt.to(icrs, azzd, hadec_obs); + + std::cout << "\n\nFROM OBSERVED TO ICRS:\n"; + std::cout << "OBS COORD EPOCH: " << radec_obs.epoch().UTC() << "\n"; + std::cout << "RA_OBS = " << radec_obs.x().sexagesimal(true) << "\n"; + std::cout << "DEC_OBS = " << radec_obs.y().sexagesimal() << "\n"; + std::cout << "RA_ICRS = " << icrs.x().sexagesimal(true) << "\n"; + std::cout << "DEC_ICRS = " << icrs.y().sexagesimal() << "\n"; + + std::cout << "\n\nFROM OBSERVED TO OBSERVED:\n"; + std::cout << "OBS COORD EPOCH: " << radec_obs.epoch().UTC() << "\n"; + std::cout << "RA_OBS = " << radec_obs.x().sexagesimal(true) << "\n"; + std::cout << "DEC_OBS = " << radec_obs.y().sexagesimal() << "\n"; + std::cout << "HA_OBS = " << hadec_obs.x().sexagesimal(true) << "\n"; + std::cout << "AZ = " << azzd.x().sexagesimal() << "\n"; + std::cout << "ZD = " << azzd.y().sexagesimal() << "\n"; + + azalt = pt; + std::cout << "ALT = " << azalt.y().sexagesimal() << "\n"; + + return 0; +} diff --git a/tests/mcc_pzone_test.cpp b/tests/mcc_pzone_test.cpp new file mode 100644 index 0000000..f1b8b81 --- /dev/null +++ b/tests/mcc_pzone_test.cpp @@ -0,0 +1,70 @@ +#include + +#include +#include +#include + +using namespace mcc::impl; + +typedef MccAltLimitPZ pz_minalt_t; +typedef MccAltLimitPZ pz_maxalt_t; + +static MccSkyPoint::ccte_t::engine_state_t saoras{.meteo{.temperature = 0.0, .humidity = 0.5, .pressure = 1010.0}, + .wavelength = 0.5, + .lat = 43.646711_degs, + .lon = 41.440732_degs, + .elev = 2100.0}; + +int main() +{ + MccSkyPoint::cctEngine.setStateERFA(saoras); + + pz_minalt_t MinAltPZ(10.0_degs, 43.646711_degs); + pz_maxalt_t MaxAltPZ(85.0_degs, 43.646711_degs); + + + MccPZoneContainer cont; + + cont.addPZone(MinAltPZ); + auto sz = cont.addPZone(MaxAltPZ); + + std::cout << sz << " pzones were added\n"; + + MccSkyPoint sp; + + MccAngleAZ az = 125.1_degs; + MccAngleZD zd = 4.2_degs; + sp.from(MccSkyAZZD{az, zd}); + + std::vector inzone; + bool flag; + + std::cout << "Sky point AZ-ZD: [" << az.degrees() << ", " << zd.degrees() << "]\n"; + auto err = cont.inPZone(sp, &flag, &inzone); + if (!err) { + std::cout << "Check 'in zone' flag: common flag = " << std::boolalpha << flag << " :\n"; + for (int i = 0; i < sz; ++i) { + std::cout << "\t" << i + 1 << "-th pzone: " << std::boolalpha << inzone[i] << "\n"; + } + } else { + std::cout << "ERR: " << err.message() << "\n"; + } + + std::cout << "\n\n"; + // inzone.clear(); + + zd = 82.4356_degs; + sp.from(MccSkyAZZD{az, zd}); + std::cout << "Sky point AZ-ZD: [" << az.degrees() << ", " << zd.degrees() << "]\n"; + err = cont.inPZone(sp, &flag, &inzone); + if (!err) { + std::cout << "Check 'in zone' flag: common flag = " << std::boolalpha << flag << " :\n"; + for (int i = 0; i < sz; ++i) { + std::cout << "\t" << i + 1 << "-th pzone: " << std::boolalpha << inzone[i] << "\n"; + } + } else { + std::cout << "ERR: " << err.message() << "\n"; + } + + return 0; +} diff --git a/tests/mcc_telemetry_test.cpp b/tests/mcc_telemetry_test.cpp new file mode 100644 index 0000000..cb50ded --- /dev/null +++ b/tests/mcc_telemetry_test.cpp @@ -0,0 +1,90 @@ +#include + +#include + +#include +#include + + +static std::random_device rd; +static std::mt19937 gen(rd()); +static std::uniform_int_distribution tm_distrib(100, 700); +static std::uniform_real_distribution x_distrib(1000, 7000); +static std::uniform_real_distribution y_distrib(1000, 7000); +static std::uniform_real_distribution xs_distrib(100, 700); +static std::uniform_real_distribution ys_distrib(100, 700); + +struct hw_t { + static constexpr std::string_view hardwareName{"HW-TEST"}; + + typedef int error_t; + + enum class hardware_movement_state_t : int { + HW_MOVE_ERROR = -1, + HW_MOVE_STOPPED = 0, + HW_MOVE_STOPPING, + HW_MOVE_SLEWING, + HW_MOVE_ADJUSTING, + HW_MOVE_TRACKING, + HW_MOVE_GUIDING + }; + + struct hardware_state_t { + mcc::impl::MccGenXY XY{1.0, 1.0}, speedXY{2.0, 2.0}; + hardware_movement_state_t movementState{hardware_movement_state_t::HW_MOVE_STOPPED}; + }; + + + error_t hardwareSetState(hardware_state_t const&) + { + return 0; + } + + + error_t hardwareGetState(hardware_state_t* state) + { + auto ms = std::chrono::milliseconds(tm_distrib(gen)); + std::cout << "\tgetState running " << ms << " ..."; + + std::this_thread::sleep_for(ms); + + std::cout << "\tdone!\n"; + + *state = hardware_state_t{.XY{x_distrib(gen), y_distrib(gen)}, .speedXY{xs_distrib(gen), ys_distrib(gen)}}; + + return 0; + } + + error_t hardwareInit() + { + return 0; + } +}; + + +static_assert(mcc::mcc_hardware_c, "!!!!!"); + + +typedef mcc::impl::MccTelemetry t_t; + +int main() +{ + hw_t hw; + mcc::impl::MccMountDefaultForkPec pcm; + + t_t tlm(&hw, &pcm); + typename t_t::telemetry_data_t tdata; + + for (int i = 0; i < 20; ++i) { + std::cout << std::format("{}-th run\n", i + 1); + + auto err = tlm.telemetryData(&tdata); + std::cout << "\tgot hw: XY = {" << tdata.hwState.XY.x() << ", " << tdata.hwState.XY.y() << "}; speedXY = {" + << tdata.hwState.speedXY.x() << ", " << tdata.hwState.speedXY.y() << "}\n"; + if (err) { + std::cout << "ERR: " << err.message() << "\n"; + } + } + + return 0; +}