From 6345e1388e673ec2e0d17e2a297af0365d755143 Mon Sep 17 00:00:00 2001 From: avcopan Date: Wed, 24 Sep 2025 16:29:10 -0400 Subject: [PATCH] Add SLATEC --- SLATEC/CMakeLists.txt | 15 + SLATEC/README.md | 60 +++ SLATEC/pixi.toml | 13 + SLATEC/recipe.yaml | 26 ++ SLATEC/src/d1mach.f | 502 ++++++++++++++++++++++++ SLATEC/src/d9b0mp.f | 247 ++++++++++++ SLATEC/src/d9b1mp.f | 249 ++++++++++++ SLATEC/src/dasum.f | 80 ++++ SLATEC/src/davint.f | 214 ++++++++++ SLATEC/src/daxpy.f | 92 +++++ SLATEC/src/dbesi0.f | 78 ++++ SLATEC/src/dbesj0.f | 73 ++++ SLATEC/src/dbesj1.f | 82 ++++ SLATEC/src/dbesk0.f | 83 ++++ SLATEC/src/dbint4.f | 241 ++++++++++++ SLATEC/src/dbnfac.f | 139 +++++++ SLATEC/src/dbnslv.f | 81 ++++ SLATEC/src/dbsi0e.f | 208 ++++++++++ SLATEC/src/dbsk0e.f | 164 ++++++++ SLATEC/src/dbspvd.f | 162 ++++++++ SLATEC/src/dbspvn.f | 123 ++++++ SLATEC/src/dbvalu.f | 165 ++++++++ SLATEC/src/dcsevl.f | 65 ++++ SLATEC/src/ddeabm.f | 688 ++++++++++++++++++++++++++++++++ SLATEC/src/dderkf.f | 698 +++++++++++++++++++++++++++++++++ SLATEC/src/ddes.f | 430 ++++++++++++++++++++ SLATEC/src/ddot.f | 89 +++++ SLATEC/src/dfehl.f | 107 +++++ SLATEC/src/dfzero.f | 225 +++++++++++ SLATEC/src/dgaus8.f | 201 ++++++++++ SLATEC/src/dgeco.f | 207 ++++++++++ SLATEC/src/dgefa.f | 117 ++++++ SLATEC/src/dgefs.f | 165 ++++++++ SLATEC/src/dgesl.f | 131 +++++++ SLATEC/src/dhstrt.f | 350 +++++++++++++++++ SLATEC/src/dhvnrm.f | 36 ++ SLATEC/src/dintp.f | 141 +++++++ SLATEC/src/dintrv.f | 118 ++++++ SLATEC/src/drf.f | 340 ++++++++++++++++ SLATEC/src/drkfs.f | 726 ++++++++++++++++++++++++++++++++++ SLATEC/src/dscal.f | 80 ++++ SLATEC/src/dsifa.f | 237 +++++++++++ SLATEC/src/dsisl.f | 187 +++++++++ SLATEC/src/dsteps.f | 577 +++++++++++++++++++++++++++ SLATEC/src/dswap.f | 102 +++++ SLATEC/src/fdump.f | 31 ++ SLATEC/src/i1mach.f | 888 ++++++++++++++++++++++++++++++++++++++++++ SLATEC/src/idamax.f | 82 ++++ SLATEC/src/initds.f | 54 +++ SLATEC/src/j4save.f | 65 ++++ SLATEC/src/xercnt.f | 60 +++ SLATEC/src/xerhlt.f | 39 ++ SLATEC/src/xermsg.f | 364 +++++++++++++++++ SLATEC/src/xerprn.f | 228 +++++++++++ SLATEC/src/xersve.f | 155 ++++++++ SLATEC/src/xgetua.f | 51 +++ pixi.toml | 3 +- 57 files changed, 11133 insertions(+), 1 deletion(-) create mode 100644 SLATEC/CMakeLists.txt create mode 100644 SLATEC/README.md create mode 100644 SLATEC/pixi.toml create mode 100644 SLATEC/recipe.yaml create mode 100644 SLATEC/src/d1mach.f create mode 100644 SLATEC/src/d9b0mp.f create mode 100644 SLATEC/src/d9b1mp.f create mode 100644 SLATEC/src/dasum.f create mode 100644 SLATEC/src/davint.f create mode 100644 SLATEC/src/daxpy.f create mode 100644 SLATEC/src/dbesi0.f create mode 100644 SLATEC/src/dbesj0.f create mode 100644 SLATEC/src/dbesj1.f create mode 100644 SLATEC/src/dbesk0.f create mode 100644 SLATEC/src/dbint4.f create mode 100644 SLATEC/src/dbnfac.f create mode 100644 SLATEC/src/dbnslv.f create mode 100644 SLATEC/src/dbsi0e.f create mode 100644 SLATEC/src/dbsk0e.f create mode 100644 SLATEC/src/dbspvd.f create mode 100644 SLATEC/src/dbspvn.f create mode 100644 SLATEC/src/dbvalu.f create mode 100644 SLATEC/src/dcsevl.f create mode 100644 SLATEC/src/ddeabm.f create mode 100644 SLATEC/src/dderkf.f create mode 100644 SLATEC/src/ddes.f create mode 100644 SLATEC/src/ddot.f create mode 100644 SLATEC/src/dfehl.f create mode 100644 SLATEC/src/dfzero.f create mode 100644 SLATEC/src/dgaus8.f create mode 100644 SLATEC/src/dgeco.f create mode 100644 SLATEC/src/dgefa.f create mode 100644 SLATEC/src/dgefs.f create mode 100644 SLATEC/src/dgesl.f create mode 100644 SLATEC/src/dhstrt.f create mode 100644 SLATEC/src/dhvnrm.f create mode 100644 SLATEC/src/dintp.f create mode 100644 SLATEC/src/dintrv.f create mode 100644 SLATEC/src/drf.f create mode 100644 SLATEC/src/drkfs.f create mode 100644 SLATEC/src/dscal.f create mode 100644 SLATEC/src/dsifa.f create mode 100644 SLATEC/src/dsisl.f create mode 100644 SLATEC/src/dsteps.f create mode 100644 SLATEC/src/dswap.f create mode 100644 SLATEC/src/fdump.f create mode 100644 SLATEC/src/i1mach.f create mode 100644 SLATEC/src/idamax.f create mode 100644 SLATEC/src/initds.f create mode 100644 SLATEC/src/j4save.f create mode 100644 SLATEC/src/xercnt.f create mode 100644 SLATEC/src/xerhlt.f create mode 100644 SLATEC/src/xermsg.f create mode 100644 SLATEC/src/xerprn.f create mode 100644 SLATEC/src/xersve.f create mode 100644 SLATEC/src/xgetua.f diff --git a/SLATEC/CMakeLists.txt b/SLATEC/CMakeLists.txt new file mode 100644 index 0000000..a6a3076 --- /dev/null +++ b/SLATEC/CMakeLists.txt @@ -0,0 +1,15 @@ +cmake_minimum_required(VERSION 3.16) +project(slatec Fortran) + +file(GLOB LIBRARY_SOURCES "${PROJECT_SOURCE_DIR}/src/*.f") + +add_library(slatec SHARED ${LIBRARY_SOURCES}) + +include(GNUInstallDirs) +install( + TARGETS ${PROJECT_NAME} + EXPORT ${PROJECT_NAME}Targets + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + RUNTIME DESTINATION ${BINDIR} +) \ No newline at end of file diff --git a/SLATEC/README.md b/SLATEC/README.md new file mode 100644 index 0000000..5cbf40a --- /dev/null +++ b/SLATEC/README.md @@ -0,0 +1,60 @@ +# SLATEC + +These files are from the SLATEC Common Mathematical Library, Version 4.1, July 1993. + +### Installation using Conda + +The most direct way to install the code is through the conda package manager. +If you have conda installed, +(1) activate an environment in you wish to use to install SLATEC, and +(2) run the install command: +``` +conda install -c auto-mech slatec +``` + +If you do not have a preferred Conda environment set up, an empty environment with no packages can be created and activated with the following commands +``` +conda create --name myenv +conda activate myenv +``` +where `myenv` should be replaced with your preferred name for the environment. + +Alternatively, we also recommend building our own pre-set Auto-Mech environment, which includes SLATEC and the codes which use it. This environment can be created and activated with the commands: +``` +conda env create auto-mech/amech-env +conda activate amech-env +``` + +If your Conda commands are not functioning, you may need to iniliatize Conda via the command +``` +. /path/to/conda.sh +``` +which places Conda executables in your PATH. The specific location of conda.sh depends on the Conda install. + + +If you do not have conda, it can be installed using the shell script +`debug/install-conda.sh`. + +### Building from source without Conda + +Run build.sh, which uses cmake to compile SLATEC: +``` +bash build.sh +``` + +Note that the results of the `make install` in build.sh will depend on your system setup. + + +## Notice + +Author: +Giuseppe Borzi' +e-mail: etana@tiscalinet.it +http://web.tiscalinet.it/gborzi +fax: +39 1782235968 +Assistant Professor at the Univ. of Messina - Italia + +License: +General Public License. Slatec is 'Freely distributable' as they say. + +For further details, see . diff --git a/SLATEC/pixi.toml b/SLATEC/pixi.toml new file mode 100644 index 0000000..b155979 --- /dev/null +++ b/SLATEC/pixi.toml @@ -0,0 +1,13 @@ +[workspace] +channels = ["https://prefix.dev/conda-forge"] +platforms = ["osx-arm64", "osx-64", "linux-64", "win-64"] +preview = ["pixi-build"] + +[dependencies] +slatec = { path = "." } + +[package] +name = "slatec" + +[package.build] +backend = { name = "pixi-build-rattler-build", version = "0.3.*" } \ No newline at end of file diff --git a/SLATEC/recipe.yaml b/SLATEC/recipe.yaml new file mode 100644 index 0000000..92dbde9 --- /dev/null +++ b/SLATEC/recipe.yaml @@ -0,0 +1,26 @@ +package: + name: slatec + version: 4.3.0 + +source: + path: . + use_gitignore: true + +build: + number: 0 + script: | + cmake $CMAKE_ARGS \ + -GNinja \ + -DCMAKE_BUILD_TYPE=Release \ + -DCMAKE_INSTALL_PREFIX=$PREFIX \ + -DCMAKE_EXPORT_COMPILE_COMMANDS=ON \ + -B $SRC_DIR/../build \ + -S . + + cmake --build $SRC_DIR/../build --target install + +requirements: + build: + - ${{ compiler('fortran') }} + - cmake + - ninja \ No newline at end of file diff --git a/SLATEC/src/d1mach.f b/SLATEC/src/d1mach.f new file mode 100644 index 0000000..6f10f70 --- /dev/null +++ b/SLATEC/src/d1mach.f @@ -0,0 +1,502 @@ +*DECK D1MACH + DOUBLE PRECISION FUNCTION D1MACH (I) +C***BEGIN PROLOGUE D1MACH +C***PURPOSE Return floating point machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C D1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument, and can be referenced as follows: +C +C D = D1MACH(I) +C +C where I=1,...,5. The (output) value of D above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. +C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. +C D1MACH( 3) = B**(-T), the smallest relative spacing. +C D1MACH( 4) = B**(1-T), the largest relative spacing. +C D1MACH( 5) = LOG10(B) +C +C Assume double precision numbers are represented in the T-digit, +C base-B form +C +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and +C EMIN .LE. E .LE. EMAX. +C +C The values of B, T, EMIN and EMAX are provided in I1MACH as +C follows: +C I1MACH(10) = B, the base. +C I1MACH(14) = T, the number of base-B digits. +C I1MACH(15) = EMIN, the smallest exponent E. +C I1MACH(16) = EMAX, the largest exponent E. +C +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890213 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 900911 Added SUN 386i constants. (WRB) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added CONVEX -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C***END PROLOGUE D1MACH +C + INTEGER SMALL(4) + INTEGER LARGE(4) + INTEGER RIGHT(4) + INTEGER DIVER(4) + INTEGER LOG10(4) +C + DOUBLE PRECISION DMACH(5) + SAVE DMACH +C + EQUIVALENCE (DMACH(1),SMALL(1)) + EQUIVALENCE (DMACH(2),LARGE(1)) + EQUIVALENCE (DMACH(3),RIGHT(1)) + EQUIVALENCE (DMACH(4),DIVER(1)) + EQUIVALENCE (DMACH(5),LOG10(1)) +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / +C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / +C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / +C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA SMALL(1) / ZC00800000 / +C DATA SMALL(2) / Z000000000 / +C DATA LARGE(1) / ZDFFFFFFFF / +C DATA LARGE(2) / ZFFFFFFFFF / +C DATA RIGHT(1) / ZCC5800000 / +C DATA RIGHT(2) / Z000000000 / +C DATA DIVER(1) / ZCC6800000 / +C DATA DIVER(2) / Z000000000 / +C DATA LOG10(1) / ZD00E730E7 / +C DATA LOG10(2) / ZC77800DC0 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O0000000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O0007777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O7770000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O7777777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA SMALL(1) / Z"3001800000000000" / +C DATA SMALL(2) / Z"3001000000000000" / +C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / +C DATA LARGE(2) / Z"4FFE000000000000" / +C DATA RIGHT(1) / Z"3FD2800000000000" / +C DATA RIGHT(2) / Z"3FD2000000000000" / +C DATA DIVER(1) / Z"3FD3800000000000" / +C DATA DIVER(2) / Z"3FD3000000000000" / +C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / +C DATA LOG10(2) / Z"3FFFF7988F8959AC" / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA SMALL(1) / 00564000000000000000B / +C DATA SMALL(2) / 00000000000000000000B / +C DATA LARGE(1) / 37757777777777777777B / +C DATA LARGE(2) / 37157777777777777777B / +C DATA RIGHT(1) / 15624000000000000000B / +C DATA RIGHT(2) / 00000000000000000000B / +C DATA DIVER(1) / 15634000000000000000B / +C DATA DIVER(2) / 00000000000000000000B / +C DATA LOG10(1) / 17164642023241175717B / +C DATA LOG10(2) / 16367571421742254654B / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn OR -pd8 COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CC0000000000000' / +C DATA DMACH(4) / Z'3CD0000000000000' / +C DATA DMACH(5) / Z'3FF34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F900000000000000000000000000000' / +C DATA DMACH(4) / Z'3F910000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE CRAY +C +C DATA SMALL(1) / 201354000000000000000B / +C DATA SMALL(2) / 000000000000000000000B / +C DATA LARGE(1) / 577767777777777777777B / +C DATA LARGE(2) / 000007777777777777774B / +C DATA RIGHT(1) / 376434000000000000000B / +C DATA RIGHT(2) / 000000000000000000000B / +C DATA DIVER(1) / 376444000000000000000B / +C DATA DIVER(2) / 000000000000000000000B / +C DATA LOG10(1) / 377774642023241175717B / +C DATA LOG10(2) / 000007571421742254654B / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - +C STATIC DMACH(5) +C +C DATA SMALL / 20K, 3*0 / +C DATA LARGE / 77777K, 3*177777K / +C DATA RIGHT / 31420K, 3*0 / +C DATA DIVER / 32020K, 3*0 / +C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA DMACH(1) / '0000000000000010'X / +C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / +C DATA DMACH(3) / '0000000000003CC0'X / +C DATA DMACH(4) / '0000000000003CD0'X / +C DATA DMACH(5) / '79FF509F44133FF3'X / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FORMAT +C +C DATA DMACH(1) / '0010000000000000'X / +C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / +C DATA DMACH(3) / '3CA0000000000000'X / +C DATA DMACH(4) / '3CB0000000000000'X / +C DATA DMACH(5) / '3FD34413509F79FF'X / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ +C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ +C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ +C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ +C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / +C +C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 16, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 15552, 0 / +C DATA DIVER(1), DIVER(2) / 15568, 0 / +C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / +C +C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) +C +C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / +C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / +C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / +C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / +C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / +C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / +C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / +C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +C DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / +C DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / +C DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / +C DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / +C DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / +C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / +C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / +C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2) / 40000B, 0 / +C DATA SMALL(3), SMALL(4) / 0, 1 / +C DATA LARGE(1), LARGE(2) / 77777B, 177777B / +C DATA LARGE(3), LARGE(4) / 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 225B / +C DATA DIVER(1), DIVER(2) / 40000B, 0 / +C DATA DIVER(3), DIVER(4) / 0, 227B / +C DATA LOG10(1), LOG10(2) / 46420B, 46502B / +C DATA LOG10(3), LOG10(4) / 76747B, 176377B / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / +C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / +C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / +C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / +C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / +C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / +C +C MACHINE CONSTANTS FOR THE IBM PC +C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION +C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. +C +C DATA SMALL(1) / 2.23D-308 / +C DATA LARGE(1) / 1.79D+308 / +C DATA RIGHT(1) / 1.11D-16 / +C DATA DIVER(1) / 2.22D-16 / +C DATA LOG10(1) / 0.301029995663981195D0 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / +C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / +C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 8388608, 0 / +C DATA LARGE(1), LARGE(2) / 2147483647, -1 / +C DATA RIGHT(1), RIGHT(2) / 612368384, 0 / +C DATA DIVER(1), DIVER(2) / 620756992, 0 / +C DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / +C +C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / +C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / +C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / +C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / +C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA SMALL(3), SMALL(4) / 0, 0 / +C DATA LARGE(1), LARGE(2) / 32767, -1 / +C DATA LARGE(3), LARGE(4) / -1, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA DIVER(3), DIVER(4) / 0, 0 / +C DATA LOG10(1), LOG10(2) / 16282, 8346 / +C DATA LOG10(3), LOG10(4) / -31493, -12296 / +C +C DATA SMALL(1), SMALL(2) / O000200, O000000 / +C DATA SMALL(3), SMALL(4) / O000000, O000000 / +C DATA LARGE(1), LARGE(2) / O077777, O177777 / +C DATA LARGE(3), LARGE(4) / O177777, O177777 / +C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / +C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / +C DATA DIVER(1), DIVER(2) / O022400, O000000 / +C DATA DIVER(3), DIVER(4) / O000000, O000000 / +C DATA LOG10(1), LOG10(2) / O037632, O020232 / +C DATA LOG10(3), LOG10(4) / O102373, O147770 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / +C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE SUN 386i +C +C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / +C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / +C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' +C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / +C DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / +C DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / +C DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / +C DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / +C +C***FIRST EXECUTABLE STATEMENT D1MACH + IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', + + 'I OUT OF BOUNDS', 1, 2) +C + D1MACH = DMACH(I) + RETURN +C + END diff --git a/SLATEC/src/d9b0mp.f b/SLATEC/src/d9b0mp.f new file mode 100644 index 0000000..e3a3246 --- /dev/null +++ b/SLATEC/src/d9b0mp.f @@ -0,0 +1,247 @@ +*DECK D9B0MP + SUBROUTINE D9B0MP (X, AMPL, THETA) +C***BEGIN PROLOGUE D9B0MP +C***SUBSIDIARY +C***PURPOSE Evaluate the modulus and phase for the J0 and Y0 Bessel +C functions. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10A1 +C***TYPE DOUBLE PRECISION (D9B0MP-D) +C***KEYWORDS BESSEL FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluate the modulus and phase for the Bessel J0 and Y0 functions. +C +C Series for BM0 on the interval 1.56250E-02 to 6.25000E-02 +C with weighted error 4.40E-32 +C log weighted error 31.36 +C significant figures required 30.02 +C decimal places required 32.14 +C +C Series for BTH0 on the interval 0. to 1.56250E-02 +C with weighted error 2.66E-32 +C log weighted error 31.57 +C significant figures required 30.67 +C decimal places required 32.40 +C +C Series for BM02 on the interval 0. to 1.56250E-02 +C with weighted error 4.72E-32 +C log weighted error 31.33 +C significant figures required 30.00 +C decimal places required 32.13 +C +C Series for BT02 on the interval 1.56250E-02 to 6.25000E-02 +C with weighted error 2.99E-32 +C log weighted error 31.52 +C significant figures required 30.61 +C decimal places required 32.32 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C 920618 Removed space from variable names. (RWC, WRB) +C***END PROLOGUE D9B0MP + DOUBLE PRECISION X, AMPL, THETA, BM0CS(37), BT02CS(39), + 1 BM02CS(40), BTH0CS(44), XMAX, PI4, Z, D1MACH, DCSEVL + LOGICAL FIRST + SAVE BM0CS, BTH0CS, BM02CS, BT02CS, PI4, NBM0, NBT02, + 1 NBM02, NBTH0, XMAX, FIRST + DATA BM0CS( 1) / +.9211656246 8277427125 7376773018 2 D-1 / + DATA BM0CS( 2) / -.1050590997 2719051024 8071637175 5 D-2 / + DATA BM0CS( 3) / +.1470159840 7687597540 5639285095 2 D-4 / + DATA BM0CS( 4) / -.5058557606 0385542233 4792932770 2 D-6 / + DATA BM0CS( 5) / +.2787254538 6324441766 3035613788 1 D-7 / + DATA BM0CS( 6) / -.2062363611 7809148026 1884101897 3 D-8 / + DATA BM0CS( 7) / +.1870214313 1388796751 3817259626 1 D-9 / + DATA BM0CS( 8) / -.1969330971 1356362002 4173077782 5 D-10 / + DATA BM0CS( 9) / +.2325973793 9992754440 1250881805 2 D-11 / + DATA BM0CS( 10) / -.3009520344 9382502728 5122473448 2 D-12 / + DATA BM0CS( 11) / +.4194521333 8506691814 7120676864 6 D-13 / + DATA BM0CS( 12) / -.6219449312 1884458259 7326742956 4 D-14 / + DATA BM0CS( 13) / +.9718260411 3360684696 0176588526 9 D-15 / + DATA BM0CS( 14) / -.1588478585 7010752073 6663596693 7 D-15 / + DATA BM0CS( 15) / +.2700072193 6713088900 8621732445 8 D-16 / + DATA BM0CS( 16) / -.4750092365 2340089924 7750478677 3 D-17 / + DATA BM0CS( 17) / +.8615128162 6043708731 9170374656 0 D-18 / + DATA BM0CS( 18) / -.1605608686 9561448157 4560270335 9 D-18 / + DATA BM0CS( 19) / +.3066513987 3144829751 8853980159 9 D-19 / + DATA BM0CS( 20) / -.5987764223 1939564306 9650561706 6 D-20 / + DATA BM0CS( 21) / +.1192971253 7482483064 8906984106 6 D-20 / + DATA BM0CS( 22) / -.2420969142 0448054894 8468258133 3 D-21 / + DATA BM0CS( 23) / +.4996751760 5106164533 7100287999 9 D-22 / + DATA BM0CS( 24) / -.1047493639 3511585100 9504051199 9 D-22 / + DATA BM0CS( 25) / +.2227786843 7974681010 4818346666 6 D-23 / + DATA BM0CS( 26) / -.4801813239 3981628623 7054293333 3 D-24 / + DATA BM0CS( 27) / +.1047962723 4709599564 7699626666 6 D-24 / + DATA BM0CS( 28) / -.2313858165 6786153251 0126080000 0 D-25 / + DATA BM0CS( 29) / +.5164823088 4626742116 3519999999 9 D-26 / + DATA BM0CS( 30) / -.1164691191 8500653895 2540159999 9 D-26 / + DATA BM0CS( 31) / +.2651788486 0433192829 5833600000 0 D-27 / + DATA BM0CS( 32) / -.6092559503 8257284976 9130666666 6 D-28 / + DATA BM0CS( 33) / +.1411804686 1442593080 3882666666 6 D-28 / + DATA BM0CS( 34) / -.3298094961 2317372457 5061333333 3 D-29 / + DATA BM0CS( 35) / +.7763931143 0740650317 1413333333 3 D-30 / + DATA BM0CS( 36) / -.1841031343 6614584784 2133333333 3 D-30 / + DATA BM0CS( 37) / +.4395880138 5943107371 0079999999 9 D-31 / + DATA BTH0CS( 1) / -.2490178086 2128936717 7097937899 67 D+0 / + DATA BTH0CS( 2) / +.4855029960 9623749241 0486155354 85 D-3 / + DATA BTH0CS( 3) / -.5451183734 5017204950 6562735635 05 D-5 / + DATA BTH0CS( 4) / +.1355867305 9405964054 3774459299 03 D-6 / + DATA BTH0CS( 5) / -.5569139890 2227626227 5832184149 20 D-8 / + DATA BTH0CS( 6) / +.3260903182 4994335304 0042057194 68 D-9 / + DATA BTH0CS( 7) / -.2491880786 2461341125 2379038779 93 D-10 / + DATA BTH0CS( 8) / +.2344937742 0882520554 3524135648 91 D-11 / + DATA BTH0CS( 9) / -.2609653444 4310387762 1775747661 36 D-12 / + DATA BTH0CS( 10) / +.3335314042 0097395105 8699550149 23 D-13 / + DATA BTH0CS( 11) / -.4789000044 0572684646 7507705574 09 D-14 / + DATA BTH0CS( 12) / +.7595617843 6192215972 6425685452 48 D-15 / + DATA BTH0CS( 13) / -.1313155601 6891440382 7733974876 33 D-15 / + DATA BTH0CS( 14) / +.2448361834 5240857495 4268207383 55 D-16 / + DATA BTH0CS( 15) / -.4880572981 0618777683 2567619183 31 D-17 / + DATA BTH0CS( 16) / +.1032728502 9786316149 2237563612 04 D-17 / + DATA BTH0CS( 17) / -.2305763381 5057217157 0047445270 25 D-18 / + DATA BTH0CS( 18) / +.5404444300 1892693993 0171084837 65 D-19 / + DATA BTH0CS( 19) / -.1324069519 4366572724 1550328823 85 D-19 / + DATA BTH0CS( 20) / +.3378079562 1371970203 4247921247 22 D-20 / + DATA BTH0CS( 21) / -.8945762915 7111779003 0269262922 99 D-21 / + DATA BTH0CS( 22) / +.2451990688 9219317090 8999086514 05 D-21 / + DATA BTH0CS( 23) / -.6938842287 6866318680 1399331576 57 D-22 / + DATA BTH0CS( 24) / +.2022827871 4890138392 9463033377 91 D-22 / + DATA BTH0CS( 25) / -.6062850000 2335483105 7941953717 64 D-23 / + DATA BTH0CS( 26) / +.1864974896 4037635381 8237883962 70 D-23 / + DATA BTH0CS( 27) / -.5878373238 4849894560 2450365308 67 D-24 / + DATA BTH0CS( 28) / +.1895859144 7999563485 5311795035 13 D-24 / + DATA BTH0CS( 29) / -.6248197937 2258858959 2916207285 65 D-25 / + DATA BTH0CS( 30) / +.2101790168 4551024686 6386335290 74 D-25 / + DATA BTH0CS( 31) / -.7208430093 5209253690 8139339924 46 D-26 / + DATA BTH0CS( 32) / +.2518136389 2474240867 1564059767 46 D-26 / + DATA BTH0CS( 33) / -.8951804225 8785778806 1439459536 43 D-27 / + DATA BTH0CS( 34) / +.3235723747 9762298533 2562358685 87 D-27 / + DATA BTH0CS( 35) / -.1188301051 9855353657 0471441137 96 D-27 / + DATA BTH0CS( 36) / +.4430628690 7358104820 5792319417 31 D-28 / + DATA BTH0CS( 37) / -.1676100964 8834829495 7920101356 81 D-28 / + DATA BTH0CS( 38) / +.6429294692 1207466972 5323939660 88 D-29 / + DATA BTH0CS( 39) / -.2499226116 6978652421 2072136827 63 D-29 / + DATA BTH0CS( 40) / +.9839979429 9521955672 8282603553 18 D-30 / + DATA BTH0CS( 41) / -.3922037524 2408016397 9891316261 58 D-30 / + DATA BTH0CS( 42) / +.1581810703 0056522138 5906188456 92 D-30 / + DATA BTH0CS( 43) / -.6452550614 4890715944 3440983654 26 D-31 / + DATA BTH0CS( 44) / +.2661111136 9199356137 1770183463 67 D-31 / + DATA BM02CS( 1) / +.9500415145 2283813693 3086133556 0 D-1 / + DATA BM02CS( 2) / -.3801864682 3656709917 4808156685 1 D-3 / + DATA BM02CS( 3) / +.2258339301 0314811929 5182992722 4 D-5 / + DATA BM02CS( 4) / -.3895725802 3722287647 3062141260 5 D-7 / + DATA BM02CS( 5) / +.1246886416 5120816979 3099052972 5 D-8 / + DATA BM02CS( 6) / -.6065949022 1025037798 0383505838 7 D-10 / + DATA BM02CS( 7) / +.4008461651 4217469910 1527597104 5 D-11 / + DATA BM02CS( 8) / -.3350998183 3980942184 6729879457 4 D-12 / + DATA BM02CS( 9) / +.3377119716 5174173670 6326434199 6 D-13 / + DATA BM02CS( 10) / -.3964585901 6350127005 6935629582 3 D-14 / + DATA BM02CS( 11) / +.5286111503 8838572173 8793974473 5 D-15 / + DATA BM02CS( 12) / -.7852519083 4508523136 5464024349 3 D-16 / + DATA BM02CS( 13) / +.1280300573 3866822010 1163407344 9 D-16 / + DATA BM02CS( 14) / -.2263996296 3914297762 8709924488 4 D-17 / + DATA BM02CS( 15) / +.4300496929 6567903886 4641029047 7 D-18 / + DATA BM02CS( 16) / -.8705749805 1325870797 4753545145 5 D-19 / + DATA BM02CS( 17) / +.1865862713 9620951411 8144277205 0 D-19 / + DATA BM02CS( 18) / -.4210482486 0930654573 4508697230 1 D-20 / + DATA BM02CS( 19) / +.9956676964 2284009915 8162741784 2 D-21 / + DATA BM02CS( 20) / -.2457357442 8053133596 0592147854 7 D-21 / + DATA BM02CS( 21) / +.6307692160 7620315680 8735370705 9 D-22 / + DATA BM02CS( 22) / -.1678773691 4407401426 9333117238 8 D-22 / + DATA BM02CS( 23) / +.4620259064 6739044337 7087813608 7 D-23 / + DATA BM02CS( 24) / -.1311782266 8603087322 3769340249 6 D-23 / + DATA BM02CS( 25) / +.3834087564 1163028277 4792244027 6 D-24 / + DATA BM02CS( 26) / -.1151459324 0777412710 7261329357 6 D-24 / + DATA BM02CS( 27) / +.3547210007 5233385230 7697134521 3 D-25 / + DATA BM02CS( 28) / -.1119218385 8150046462 6435594217 6 D-25 / + DATA BM02CS( 29) / +.3611879427 6298378316 9840499425 7 D-26 / + DATA BM02CS( 30) / -.1190687765 9133331500 9264176246 3 D-26 / + DATA BM02CS( 31) / +.4005094059 4039681318 0247644953 6 D-27 / + DATA BM02CS( 32) / -.1373169422 4522123905 9519391601 7 D-27 / + DATA BM02CS( 33) / +.4794199088 7425315859 9649152643 7 D-28 / + DATA BM02CS( 34) / -.1702965627 6241095840 0699447645 2 D-28 / + DATA BM02CS( 35) / +.6149512428 9363300715 0357516132 4 D-29 / + DATA BM02CS( 36) / -.2255766896 5818283499 4430023724 2 D-29 / + DATA BM02CS( 37) / +.8399707509 2942994860 6165835320 0 D-30 / + DATA BM02CS( 38) / -.3172997595 5626023555 6742393615 2 D-30 / + DATA BM02CS( 39) / +.1215205298 8812985545 8333302651 4 D-30 / + DATA BM02CS( 40) / -.4715852749 7544386930 1321056804 5 D-31 / + DATA BT02CS( 1) / -.2454829521 3424597462 0504672493 24 D+0 / + DATA BT02CS( 2) / +.1254412103 9084615780 7853317782 99 D-2 / + DATA BT02CS( 3) / -.3125395041 4871522854 9734467095 71 D-4 / + DATA BT02CS( 4) / +.1470977824 9940831164 4534269693 14 D-5 / + DATA BT02CS( 5) / -.9954348893 7950033643 4688503511 58 D-7 / + DATA BT02CS( 6) / +.8549316673 3203041247 5787113977 51 D-8 / + DATA BT02CS( 7) / -.8698975952 6554334557 9855121791 92 D-9 / + DATA BT02CS( 8) / +.1005209953 3559791084 5401010821 53 D-9 / + DATA BT02CS( 9) / -.1282823060 1708892903 4836236855 44 D-10 / + DATA BT02CS( 10) / +.1773170078 1805131705 6557504510 23 D-11 / + DATA BT02CS( 11) / -.2617457456 9485577488 6362841809 25 D-12 / + DATA BT02CS( 12) / +.4082835138 9972059621 9664812211 03 D-13 / + DATA BT02CS( 13) / -.6675166823 9742720054 6067495542 61 D-14 / + DATA BT02CS( 14) / +.1136576139 3071629448 3924695499 51 D-14 / + DATA BT02CS( 15) / -.2005118962 0647160250 5592664121 17 D-15 / + DATA BT02CS( 16) / +.3649797879 4766269635 7205914641 06 D-16 / + DATA BT02CS( 17) / -.6830963756 4582303169 3558437888 00 D-17 / + DATA BT02CS( 18) / +.1310758314 5670756620 0571042679 46 D-17 / + DATA BT02CS( 19) / -.2572336310 1850607778 7571306495 99 D-18 / + DATA BT02CS( 20) / +.5152165744 1863959925 2677809493 33 D-19 / + DATA BT02CS( 21) / -.1051301756 3758802637 9407414613 33 D-19 / + DATA BT02CS( 22) / +.2182038199 1194813847 3010845013 33 D-20 / + DATA BT02CS( 23) / -.4600470121 0362160577 2259054933 33 D-21 / + DATA BT02CS( 24) / +.9840700692 5466818520 9536511999 99 D-22 / + DATA BT02CS( 25) / -.2133403803 5728375844 7359863466 66 D-22 / + DATA BT02CS( 26) / +.4683103642 3973365296 0662869333 33 D-23 / + DATA BT02CS( 27) / -.1040021369 1985747236 5133823999 99 D-23 / + DATA BT02CS( 28) / +.2334910567 7301510051 7777408000 00 D-24 / + DATA BT02CS( 29) / -.5295682532 3318615788 0497493333 33 D-25 / + DATA BT02CS( 30) / +.1212634195 2959756829 1962879999 99 D-25 / + DATA BT02CS( 31) / -.2801889708 2289428760 2756266666 66 D-26 / + DATA BT02CS( 32) / +.6529267898 7012873342 5937066666 66 D-27 / + DATA BT02CS( 33) / -.1533798006 1873346427 8357333333 33 D-27 / + DATA BT02CS( 34) / +.3630588430 6364536682 3594666666 66 D-28 / + DATA BT02CS( 35) / -.8656075571 3629122479 1722666666 66 D-29 / + DATA BT02CS( 36) / +.2077990997 2536284571 2383999999 99 D-29 / + DATA BT02CS( 37) / -.5021117022 1417221674 3253333333 33 D-30 / + DATA BT02CS( 38) / +.1220836027 9441714184 1919999999 99 D-30 / + DATA BT02CS( 39) / -.2986005626 7039913454 2506666666 66 D-31 / + DATA PI4 / 0.7853981633 9744830961 5660845819 876 D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT D9B0MP + IF (FIRST) THEN + ETA = 0.1*REAL(D1MACH(3)) + NBM0 = INITDS (BM0CS, 37, ETA) + NBT02 = INITDS (BT02CS, 39, ETA) + NBM02 = INITDS (BM02CS, 40, ETA) + NBTH0 = INITDS (BTH0CS, 44, ETA) +C + XMAX = 1.0D0/D1MACH(4) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 4.D0) CALL XERMSG ('SLATEC', 'D9B0MP', + + 'X MUST BE GE 4', 1, 2) +C + IF (X.GT.8.D0) GO TO 20 + Z = (128.D0/(X*X) - 5.D0)/3.D0 + AMPL = (.75D0 + DCSEVL (Z, BM0CS, NBM0))/SQRT(X) + THETA = X - PI4 + DCSEVL (Z, BT02CS, NBT02)/X + RETURN +C + 20 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'D9B0MP', + + 'NO PRECISION BECAUSE X IS BIG', 2, 2) +C + Z = 128.D0/(X*X) - 1.D0 + AMPL = (.75D0 + DCSEVL (Z, BM02CS, NBM02))/SQRT(X) + THETA = X - PI4 + DCSEVL (Z, BTH0CS, NBTH0)/X + RETURN +C + END diff --git a/SLATEC/src/d9b1mp.f b/SLATEC/src/d9b1mp.f new file mode 100644 index 0000000..1b87c7f --- /dev/null +++ b/SLATEC/src/d9b1mp.f @@ -0,0 +1,249 @@ +*DECK D9B1MP + SUBROUTINE D9B1MP (X, AMPL, THETA) +C***BEGIN PROLOGUE D9B1MP +C***SUBSIDIARY +C***PURPOSE Evaluate the modulus and phase for the J1 and Y1 Bessel +C functions. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10A1 +C***TYPE DOUBLE PRECISION (D9B1MP-D) +C***KEYWORDS BESSEL FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluate the modulus and phase for the Bessel J1 and Y1 functions. +C +C Series for BM1 on the interval 1.56250E-02 to 6.25000E-02 +C with weighted error 4.91E-32 +C log weighted error 31.31 +C significant figures required 30.04 +C decimal places required 32.09 +C +C Series for BT12 on the interval 1.56250E-02 to 6.25000E-02 +C with weighted error 3.33E-32 +C log weighted error 31.48 +C significant figures required 31.05 +C decimal places required 32.27 +C +C Series for BM12 on the interval 0. to 1.56250E-02 +C with weighted error 5.01E-32 +C log weighted error 31.30 +C significant figures required 29.99 +C decimal places required 32.10 +C +C Series for BTH1 on the interval 0. to 1.56250E-02 +C with weighted error 2.82E-32 +C log weighted error 31.55 +C significant figures required 31.12 +C decimal places required 32.37 +C +C***SEE ALSO DBESJ1, DBESY1 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900720 Routine changed from user-callable to subsidiary. (WRB) +C 920618 Removed space from variable name and code restructured to +C use IF-THEN-ELSE. (RWC, WRB) +C***END PROLOGUE D9B1MP + DOUBLE PRECISION X, AMPL, THETA, BM1CS(37), BT12CS(39), + 1 BM12CS(40), BTH1CS(44), XMAX, PI4, Z, D1MACH, DCSEVL + LOGICAL FIRST + SAVE BM1CS, BT12CS, BTH1CS, BM12CS, PI4, NBM1, NBT12, + 1 NBM12, NBTH1, XMAX, FIRST + DATA BM1CS( 1) / +.1069845452 6180630149 6998530853 8 D+0 / + DATA BM1CS( 2) / +.3274915039 7159649007 2905514344 5 D-2 / + DATA BM1CS( 3) / -.2987783266 8316985920 3044577793 8 D-4 / + DATA BM1CS( 4) / +.8331237177 9919745313 9322266902 3 D-6 / + DATA BM1CS( 5) / -.4112665690 3020073048 9638172549 8 D-7 / + DATA BM1CS( 6) / +.2855344228 7892152207 1975766316 1 D-8 / + DATA BM1CS( 7) / -.2485408305 4156238780 6002659605 5 D-9 / + DATA BM1CS( 8) / +.2543393338 0725824427 4248439717 4 D-10 / + DATA BM1CS( 9) / -.2941045772 8229675234 8975082790 9 D-11 / + DATA BM1CS( 10) / +.3743392025 4939033092 6505615362 6 D-12 / + DATA BM1CS( 11) / -.5149118293 8211672187 2054824352 7 D-13 / + DATA BM1CS( 12) / +.7552535949 8651439080 3404076419 9 D-14 / + DATA BM1CS( 13) / -.1169409706 8288464441 6629062246 4 D-14 / + DATA BM1CS( 14) / +.1896562449 4347915717 2182460506 0 D-15 / + DATA BM1CS( 15) / -.3201955368 6932864206 6477531639 4 D-16 / + DATA BM1CS( 16) / +.5599548399 3162041144 8416990549 3 D-17 / + DATA BM1CS( 17) / -.1010215894 7304324431 1939044454 4 D-17 / + DATA BM1CS( 18) / +.1873844985 7275629833 0204271957 3 D-18 / + DATA BM1CS( 19) / -.3563537470 3285802192 7430143999 9 D-19 / + DATA BM1CS( 20) / +.6931283819 9712383304 2276351999 9 D-20 / + DATA BM1CS( 21) / -.1376059453 4065001522 5140893013 3 D-20 / + DATA BM1CS( 22) / +.2783430784 1070802205 9977932799 9 D-21 / + DATA BM1CS( 23) / -.5727595364 3205616893 4866943999 9 D-22 / + DATA BM1CS( 24) / +.1197361445 9188926725 3575679999 9 D-22 / + DATA BM1CS( 25) / -.2539928509 8918719766 4144042666 6 D-23 / + DATA BM1CS( 26) / +.5461378289 6572959730 6961919999 9 D-24 / + DATA BM1CS( 27) / -.1189211341 7733202889 8628949333 3 D-24 / + DATA BM1CS( 28) / +.2620150977 3400815949 5782400000 0 D-25 / + DATA BM1CS( 29) / -.5836810774 2556859019 2093866666 6 D-26 / + DATA BM1CS( 30) / +.1313743500 0805957734 2361599999 9 D-26 / + DATA BM1CS( 31) / -.2985814622 5103803553 3277866666 6 D-27 / + DATA BM1CS( 32) / +.6848390471 3346049376 2559999999 9 D-28 / + DATA BM1CS( 33) / -.1584401568 2224767211 9296000000 0 D-28 / + DATA BM1CS( 34) / +.3695641006 5709380543 0101333333 3 D-29 / + DATA BM1CS( 35) / -.8687115921 1446682430 1226666666 6 D-30 / + DATA BM1CS( 36) / +.2057080846 1587634629 2906666666 6 D-30 / + DATA BM1CS( 37) / -.4905225761 1162255185 2373333333 3 D-31 / + DATA BT12CS( 1) / +.7382386012 8742974662 6208397927 64 D+0 / + DATA BT12CS( 2) / -.3336111317 4483906384 4701476811 89 D-2 / + DATA BT12CS( 3) / +.6146345488 8046964698 5148994201 86 D-4 / + DATA BT12CS( 4) / -.2402458516 1602374264 9776354695 68 D-5 / + DATA BT12CS( 5) / +.1466355557 7509746153 2105919972 04 D-6 / + DATA BT12CS( 6) / -.1184191730 5589180567 0051475049 83 D-7 / + DATA BT12CS( 7) / +.1157419896 3919197052 1254663030 55 D-8 / + DATA BT12CS( 8) / -.1300116112 9439187449 3660077945 71 D-9 / + DATA BT12CS( 9) / +.1624539114 1361731937 7421662736 67 D-10 / + DATA BT12CS( 10) / -.2208963682 1403188752 1554417701 28 D-11 / + DATA BT12CS( 11) / +.3218030425 8553177090 4743586537 78 D-12 / + DATA BT12CS( 12) / -.4965314793 2768480785 5520211353 81 D-13 / + DATA BT12CS( 13) / +.8043890043 2847825985 5588826393 17 D-14 / + DATA BT12CS( 14) / -.1358912131 0161291384 6947126822 82 D-14 / + DATA BT12CS( 15) / +.2381050439 7147214869 6765296059 73 D-15 / + DATA BT12CS( 16) / -.4308146636 3849106724 4712414207 99 D-16 / + DATA BT12CS( 17) / +.8020254403 2771002434 9935125504 00 D-17 / + DATA BT12CS( 18) / -.1531631064 2462311864 2300274687 99 D-17 / + DATA BT12CS( 19) / +.2992860635 2715568924 0730405546 66 D-18 / + DATA BT12CS( 20) / -.5970996465 8085443393 8156366506 66 D-19 / + DATA BT12CS( 21) / +.1214028966 9415185024 1608526506 66 D-19 / + DATA BT12CS( 22) / -.2511511469 6612948901 0069777066 66 D-20 / + DATA BT12CS( 23) / +.5279056717 0328744850 7383807999 99 D-21 / + DATA BT12CS( 24) / -.1126050922 7550498324 3611613866 66 D-21 / + DATA BT12CS( 25) / +.2434827735 9576326659 6634624000 00 D-22 / + DATA BT12CS( 26) / -.5331726123 6931800130 0384426666 66 D-23 / + DATA BT12CS( 27) / +.1181361505 9707121039 2059903999 99 D-23 / + DATA BT12CS( 28) / -.2646536828 3353523514 8567893333 33 D-24 / + DATA BT12CS( 29) / +.5990339404 1361503945 5778133333 33 D-25 / + DATA BT12CS( 30) / -.1369085463 0829503109 1363839999 99 D-25 / + DATA BT12CS( 31) / +.3157679015 4380228326 4136533333 33 D-26 / + DATA BT12CS( 32) / -.7345791508 2084356491 4005333333 33 D-27 / + DATA BT12CS( 33) / +.1722808148 0722747930 7059200000 00 D-27 / + DATA BT12CS( 34) / -.4071690796 1286507941 0688000000 00 D-28 / + DATA BT12CS( 35) / +.9693474513 6779622700 3733333333 33 D-29 / + DATA BT12CS( 36) / -.2323763633 7765716765 3546666666 66 D-29 / + DATA BT12CS( 37) / +.5607451067 3522029406 8906666666 66 D-30 / + DATA BT12CS( 38) / -.1361646539 1539005860 5226666666 66 D-30 / + DATA BT12CS( 39) / +.3326310923 3894654388 9066666666 66 D-31 / + DATA BM12CS( 1) / +.9807979156 2330500272 7209354693 7 D-1 / + DATA BM12CS( 2) / +.1150961189 5046853061 7548348460 2 D-2 / + DATA BM12CS( 3) / -.4312482164 3382054098 8935809773 2 D-5 / + DATA BM12CS( 4) / +.5951839610 0888163078 1302980183 2 D-7 / + DATA BM12CS( 5) / -.1704844019 8269098574 0070158647 8 D-8 / + DATA BM12CS( 6) / +.7798265413 6111095086 5817382740 1 D-10 / + DATA BM12CS( 7) / -.4958986126 7664158094 9175495186 5 D-11 / + DATA BM12CS( 8) / +.4038432416 4211415168 3820226514 4 D-12 / + DATA BM12CS( 9) / -.3993046163 7251754457 6548384664 5 D-13 / + DATA BM12CS( 10) / +.4619886183 1189664943 1334243277 5 D-14 / + DATA BM12CS( 11) / -.6089208019 0953833013 4547261933 3 D-15 / + DATA BM12CS( 12) / +.8960930916 4338764821 5704804124 9 D-16 / + DATA BM12CS( 13) / -.1449629423 9420231229 1651891892 5 D-16 / + DATA BM12CS( 14) / +.2546463158 5377760561 6514964806 8 D-17 / + DATA BM12CS( 15) / -.4809472874 6478364442 5926371862 0 D-18 / + DATA BM12CS( 16) / +.9687684668 2925990490 8727583912 4 D-19 / + DATA BM12CS( 17) / -.2067213372 2779660232 4503811755 1 D-19 / + DATA BM12CS( 18) / +.4646651559 1503847318 0276780959 0 D-20 / + DATA BM12CS( 19) / -.1094966128 8483341382 4135132833 9 D-20 / + DATA BM12CS( 20) / +.2693892797 2886828609 0570761278 5 D-21 / + DATA BM12CS( 21) / -.6894992910 9303744778 1897002685 7 D-22 / + DATA BM12CS( 22) / +.1830268262 7520629098 9066855474 0 D-22 / + DATA BM12CS( 23) / -.5025064246 3519164281 5611355322 4 D-23 / + DATA BM12CS( 24) / +.1423545194 4548060396 3169363419 4 D-23 / + DATA BM12CS( 25) / -.4152191203 6164503880 6888676980 1 D-24 / + DATA BM12CS( 26) / +.1244609201 5039793258 8233007654 7 D-24 / + DATA BM12CS( 27) / -.3827336370 5693042994 3191866128 6 D-25 / + DATA BM12CS( 28) / +.1205591357 8156175353 7472398183 5 D-25 / + DATA BM12CS( 29) / -.3884536246 3764880764 3185936112 4 D-26 / + DATA BM12CS( 30) / +.1278689528 7204097219 0489528346 1 D-26 / + DATA BM12CS( 31) / -.4295146689 4479462720 6193691591 2 D-27 / + DATA BM12CS( 32) / +.1470689117 8290708864 5680270798 3 D-27 / + DATA BM12CS( 33) / -.5128315665 1060731281 8037401779 6 D-28 / + DATA BM12CS( 34) / +.1819509585 4711693854 8143737328 6 D-28 / + DATA BM12CS( 35) / -.6563031314 8419808676 1863505037 3 D-29 / + DATA BM12CS( 36) / +.2404898976 9199606531 9891487583 4 D-29 / + DATA BM12CS( 37) / -.8945966744 6906124732 3495824297 9 D-30 / + DATA BM12CS( 38) / +.3376085160 6572310266 3714897824 0 D-30 / + DATA BM12CS( 39) / -.1291791454 6206563609 1309991696 6 D-30 / + DATA BM12CS( 40) / +.5008634462 9588105206 8495150125 4 D-31 / + DATA BTH1CS( 1) / +.7474995720 3587276055 4434839696 95 D+0 / + DATA BTH1CS( 2) / -.1240077714 4651711252 5457775413 84 D-2 / + DATA BTH1CS( 3) / +.9925244240 4424527376 6414976895 92 D-5 / + DATA BTH1CS( 4) / -.2030369073 7159711052 4193753756 08 D-6 / + DATA BTH1CS( 5) / +.7535961770 5690885712 1840175836 29 D-8 / + DATA BTH1CS( 6) / -.4166161271 5343550107 6300238562 28 D-9 / + DATA BTH1CS( 7) / +.3070161807 0834890481 2451020912 16 D-10 / + DATA BTH1CS( 8) / -.2817849963 7605213992 3240088839 24 D-11 / + DATA BTH1CS( 9) / +.3079069673 9040295476 0281468216 47 D-12 / + DATA BTH1CS( 10) / -.3880330026 2803434112 7873475547 81 D-13 / + DATA BTH1CS( 11) / +.5509603960 8630904934 5617262085 62 D-14 / + DATA BTH1CS( 12) / -.8659006076 8383779940 1033989539 94 D-15 / + DATA BTH1CS( 13) / +.1485604914 1536749003 4236890606 83 D-15 / + DATA BTH1CS( 14) / -.2751952981 5904085805 3712121250 09 D-16 / + DATA BTH1CS( 15) / +.5455079609 0481089625 0362236409 23 D-17 / + DATA BTH1CS( 16) / -.1148653450 1983642749 5436310271 77 D-17 / + DATA BTH1CS( 17) / +.2553521337 7973900223 1990525335 22 D-18 / + DATA BTH1CS( 18) / -.5962149019 7413450395 7682879078 49 D-19 / + DATA BTH1CS( 19) / +.1455662290 2372718620 2883020058 33 D-19 / + DATA BTH1CS( 20) / -.3702218542 2450538201 5797760195 93 D-20 / + DATA BTH1CS( 21) / +.9776307412 5345357664 1684345179 24 D-21 / + DATA BTH1CS( 22) / -.2672682163 9668488468 7237753930 52 D-21 / + DATA BTH1CS( 23) / +.7545330038 4983271794 0381906557 64 D-22 / + DATA BTH1CS( 24) / -.2194789991 9802744897 8923833716 47 D-22 / + DATA BTH1CS( 25) / +.6564839462 3955262178 9069998174 93 D-23 / + DATA BTH1CS( 26) / -.2015560429 8370207570 7840768695 19 D-23 / + DATA BTH1CS( 27) / +.6341776855 6776143492 1446671856 70 D-24 / + DATA BTH1CS( 28) / -.2041927788 5337895634 8137699555 91 D-24 / + DATA BTH1CS( 29) / +.6719146422 0720567486 6589800185 51 D-25 / + DATA BTH1CS( 30) / -.2256907911 0207573595 7090036873 36 D-25 / + DATA BTH1CS( 31) / +.7729771989 2989706370 9269598719 29 D-26 / + DATA BTH1CS( 32) / -.2696744451 2294640913 2114240809 20 D-26 / + DATA BTH1CS( 33) / +.9574934451 8502698072 2955219336 27 D-27 / + DATA BTH1CS( 34) / -.3456916844 8890113000 1756808276 27 D-27 / + DATA BTH1CS( 35) / +.1268123481 7398436504 2119862383 74 D-27 / + DATA BTH1CS( 36) / -.4723253663 0722639860 4649937134 45 D-28 / + DATA BTH1CS( 37) / +.1785000847 8186376177 8586197964 17 D-28 / + DATA BTH1CS( 38) / -.6840436100 4510395406 2152235667 46 D-29 / + DATA BTH1CS( 39) / +.2656602867 1720419358 2934226722 12 D-29 / + DATA BTH1CS( 40) / -.1045040252 7914452917 7141614846 70 D-29 / + DATA BTH1CS( 41) / +.4161829082 5377144306 8619171970 64 D-30 / + DATA BTH1CS( 42) / -.1677163920 3643714856 5013478828 87 D-30 / + DATA BTH1CS( 43) / +.6836199777 6664389173 5359280285 28 D-31 / + DATA BTH1CS( 44) / -.2817224786 1233641166 7395746228 10 D-31 / + DATA PI4 / 0.7853981633 9744830961 5660845819 876 D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT D9B1MP + IF (FIRST) THEN + ETA = 0.1*REAL(D1MACH(3)) + NBM1 = INITDS (BM1CS, 37, ETA) + NBT12 = INITDS (BT12CS, 39, ETA) + NBM12 = INITDS (BM12CS, 40, ETA) + NBTH1 = INITDS (BTH1CS, 44, ETA) +C + XMAX = 1.0D0/D1MACH(4) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 4.0D0) THEN + CALL XERMSG ('SLATEC', 'D9B1MP', 'X must be .GE. 4', 1, 2) + AMPL = 0.0D0 + THETA = 0.0D0 + ELSE IF (X .LE. 8.0D0) THEN + Z = (128.0D0/(X*X) - 5.0D0)/3.0D0 + AMPL = (0.75D0 + DCSEVL (Z, BM1CS, NBM1))/SQRT(X) + THETA = X - 3.0D0*PI4 + DCSEVL (Z, BT12CS, NBT12)/X + ELSE + IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'D9B1MP', + + 'No precision because X is too big', 2, 2) +C + Z = 128.0D0/(X*X) - 1.0D0 + AMPL = (0.75D0 + DCSEVL (Z, BM12CS, NBM12))/SQRT(X) + THETA = X - 3.0D0*PI4 + DCSEVL (Z, BTH1CS, NBTH1)/X + ENDIF + RETURN + END diff --git a/SLATEC/src/dasum.f b/SLATEC/src/dasum.f new file mode 100644 index 0000000..6165e55 --- /dev/null +++ b/SLATEC/src/dasum.f @@ -0,0 +1,80 @@ +*DECK DASUM + DOUBLE PRECISION FUNCTION DASUM (N, DX, INCX) +C***BEGIN PROLOGUE DASUM +C***PURPOSE Compute the sum of the magnitudes of the elements of a +C vector. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A3A +C***TYPE DOUBLE PRECISION (SASUM-S, DASUM-D, SCASUM-C) +C***KEYWORDS BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C +C --Output-- +C DASUM double precision result (zero if N .LE. 0) +C +C Returns sum of magnitudes of double precision DX. +C DASUM = sum from 0 to N-1 of ABS(DX(IX+I*INCX)), +C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900821 Modified to correct problem with a negative increment. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DASUM + DOUBLE PRECISION DX(*) + INTEGER I, INCX, IX, M, MP1, N +C***FIRST EXECUTABLE STATEMENT DASUM + DASUM = 0.0D0 + IF (N .LE. 0) RETURN +C + IF (INCX .EQ. 1) GOTO 20 +C +C Code for increment not equal to 1. +C + IX = 1 + IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 + DO 10 I = 1,N + DASUM = DASUM + ABS(DX(IX)) + IX = IX + INCX + 10 CONTINUE + RETURN +C +C Code for increment equal to 1. +C +C Clean-up loop so remaining vector length is a multiple of 6. +C + 20 M = MOD(N,6) + IF (M .EQ. 0) GOTO 40 + DO 30 I = 1,M + DASUM = DASUM + ABS(DX(I)) + 30 CONTINUE + IF (N .LT. 6) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DASUM = DASUM + ABS(DX(I)) + ABS(DX(I+1)) + ABS(DX(I+2)) + + 1 ABS(DX(I+3)) + ABS(DX(I+4)) + ABS(DX(I+5)) + 50 CONTINUE + RETURN + END diff --git a/SLATEC/src/davint.f b/SLATEC/src/davint.f new file mode 100644 index 0000000..b9a255f --- /dev/null +++ b/SLATEC/src/davint.f @@ -0,0 +1,214 @@ +*DECK DAVINT + SUBROUTINE DAVINT (X, Y, N, XLO, XUP, ANS, IERR) +C***BEGIN PROLOGUE DAVINT +C***PURPOSE Integrate a function tabulated at arbitrarily spaced +C abscissas using overlapping parabolas. +C***LIBRARY SLATEC +C***CATEGORY H2A1B2 +C***TYPE DOUBLE PRECISION (AVINT-S, DAVINT-D) +C***KEYWORDS INTEGRATION, QUADRATURE, TABULATED DATA +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C DAVINT integrates a function tabulated at arbitrarily spaced +C abscissas. The limits of integration need not coincide +C with the tabulated abscissas. +C +C A method of overlapping parabolas fitted to the data is used +C provided that there are at least 3 abscissas between the +C limits of integration. DAVINT also handles two special cases. +C If the limits of integration are equal, DAVINT returns a +C result of zero regardless of the number of tabulated values. +C If there are only two function values, DAVINT uses the +C trapezoid rule. +C +C Description of Parameters +C The user must dimension all arrays appearing in the call list +C X(N), Y(N) +C +C Input-- +C X - DOUBLE PRECISION array of abscissas, which must be in +C increasing order. +C Y - DOUBLE PRECISION array of function values. i.e., +C Y(I)=FUNC(X(I)) +C N - The integer number of function values supplied. +C N .GE. 2 unless XLO = XUP. +C XLO - DOUBLE PRECISION lower limit of integration +C XUP - DOUBLE PRECISION upper limit of integration. Must have +C XLO.LE.XUP +C +C Output-- +C ANS - Double Precision computed approximate value of integral +C IERR - A status code +C --Normal Code +C =1 Means the requested integration was performed. +C --Abnormal Codes +C =2 Means XUP was less than XLO. +C =3 Means the number of X(I) between XLO and XUP +C (inclusive) was less than 3 and neither of the two +C special cases described in the abstract occurred. +C No integration was performed. +C =4 Means the restriction X(I+1).GT.X(I) was violated. +C =5 Means the number N of function values was .lt. 2. +C ANS is set to zero if IERR=2,3,4,or 5. +C +C DAVINT is documented completely in SC-M-69-335 +C Original program from *Numerical Integration* by Davis & Rabinowitz +C Adaptation and modifications by Rondall E Jones. +C +C***REFERENCES R. E. Jones, Approximate integrator of functions +C tabulated at arbitrarily spaced abscissas, +C Report SC-M-69-335, Sandia Laboratories, 1969. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 690901 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DAVINT +C + INTEGER I, IERR, INLFT, INRT, ISTART, ISTOP, N + DOUBLE PRECISION A, ANS, B, C, CA, CB, CC, FL, FR, R3, RP5, + 1 SLOPE, SUM, SYL, SYL2, SYL3, SYU, SYU2, SYU3, TERM1, TERM2, + 2 TERM3, X, X1, X12, X13, X2, X23, X3, XLO, XUP, Y + DIMENSION X(*),Y(*) +C BEGIN BLOCK PERMITTING ...EXITS TO 190 +C BEGIN BLOCK PERMITTING ...EXITS TO 180 +C***FIRST EXECUTABLE STATEMENT DAVINT + IERR = 1 + ANS = 0.0D0 + IF (XLO .GT. XUP) GO TO 160 + IF (XLO .EQ. XUP) GO TO 150 + IF (N .GE. 2) GO TO 10 + IERR = 5 + CALL XERMSG ('SLATEC', 'DAVINT', + + 'LESS THAN TWO FUNCTION VALUES WERE SUPPLIED.', + + 4, 1) +C ...............EXIT + GO TO 190 + 10 CONTINUE + DO 20 I = 2, N +C ............EXIT + IF (X(I) .LE. X(I-1)) GO TO 180 +C ...EXIT + IF (X(I) .GT. XUP) GO TO 30 + 20 CONTINUE + 30 CONTINUE + IF (N .GE. 3) GO TO 40 +C +C SPECIAL N=2 CASE + SLOPE = (Y(2) - Y(1))/(X(2) - X(1)) + FL = Y(1) + SLOPE*(XLO - X(1)) + FR = Y(2) + SLOPE*(XUP - X(2)) + ANS = 0.5D0*(FL + FR)*(XUP - XLO) +C ...............EXIT + GO TO 190 + 40 CONTINUE + IF (X(N-2) .GE. XLO) GO TO 50 + IERR = 3 + CALL XERMSG ('SLATEC', 'DAVINT', + + 'THERE WERE LESS THAN THREE FUNCTION VALUES ' // + + 'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1) +C ...............EXIT + GO TO 190 + 50 CONTINUE + IF (X(3) .LE. XUP) GO TO 60 + IERR = 3 + CALL XERMSG ('SLATEC', 'DAVINT', + + 'THERE WERE LESS THAN THREE FUNCTION VALUES ' // + + 'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1) +C ...............EXIT + GO TO 190 + 60 CONTINUE + I = 1 + 70 IF (X(I) .GE. XLO) GO TO 80 + I = I + 1 + GO TO 70 + 80 CONTINUE + INLFT = I + I = N + 90 IF (X(I) .LE. XUP) GO TO 100 + I = I - 1 + GO TO 90 + 100 CONTINUE + INRT = I + IF ((INRT - INLFT) .GE. 2) GO TO 110 + IERR = 3 + CALL XERMSG ('SLATEC', 'DAVINT', + + 'THERE WERE LESS THAN THREE FUNCTION VALUES ' // + + 'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1) +C ...............EXIT + GO TO 190 + 110 CONTINUE + ISTART = INLFT + IF (INLFT .EQ. 1) ISTART = 2 + ISTOP = INRT + IF (INRT .EQ. N) ISTOP = N - 1 +C + R3 = 3.0D0 + RP5 = 0.5D0 + SUM = 0.0D0 + SYL = XLO + SYL2 = SYL*SYL + SYL3 = SYL2*SYL +C + DO 140 I = ISTART, ISTOP + X1 = X(I-1) + X2 = X(I) + X3 = X(I+1) + X12 = X1 - X2 + X13 = X1 - X3 + X23 = X2 - X3 + TERM1 = Y(I-1)/(X12*X13) + TERM2 = -Y(I)/(X12*X23) + TERM3 = Y(I+1)/(X13*X23) + A = TERM1 + TERM2 + TERM3 + B = -(X2 + X3)*TERM1 - (X1 + X3)*TERM2 + 1 - (X1 + X2)*TERM3 + C = X2*X3*TERM1 + X1*X3*TERM2 + X1*X2*TERM3 + IF (I .GT. ISTART) GO TO 120 + CA = A + CB = B + CC = C + GO TO 130 + 120 CONTINUE + CA = 0.5D0*(A + CA) + CB = 0.5D0*(B + CB) + CC = 0.5D0*(C + CC) + 130 CONTINUE + SYU = X2 + SYU2 = SYU*SYU + SYU3 = SYU2*SYU + SUM = SUM + CA*(SYU3 - SYL3)/R3 + 1 + CB*RP5*(SYU2 - SYL2) + CC*(SYU - SYL) + CA = A + CB = B + CC = C + SYL = SYU + SYL2 = SYU2 + SYL3 = SYU3 + 140 CONTINUE + SYU = XUP + ANS = SUM + CA*(SYU**3 - SYL3)/R3 + 1 + CB*RP5*(SYU**2 - SYL2) + CC*(SYU - SYL) + 150 CONTINUE + GO TO 170 + 160 CONTINUE + IERR = 2 + CALL XERMSG ('SLATEC', 'DAVINT', + + 'THE UPPER LIMIT OF INTEGRATION WAS NOT GREATER ' // + + 'THAN THE LOWER LIMIT.', 4, 1) + 170 CONTINUE +C ......EXIT + GO TO 190 + 180 CONTINUE + IERR = 4 + CALL XERMSG ('SLATEC', 'DAVINT', + + 'THE ABSCISSAS WERE NOT STRICTLY INCREASING. MUST HAVE ' // + + 'X(I-1) .LT. X(I) FOR ALL I.', 4, 1) + 190 CONTINUE + RETURN + END diff --git a/SLATEC/src/daxpy.f b/SLATEC/src/daxpy.f new file mode 100644 index 0000000..d1a0ff6 --- /dev/null +++ b/SLATEC/src/daxpy.f @@ -0,0 +1,92 @@ +*DECK DAXPY + SUBROUTINE DAXPY (N, DA, DX, INCX, DY, INCY) +C***BEGIN PROLOGUE DAXPY +C***PURPOSE Compute a constant times a vector plus a vector. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A7 +C***TYPE DOUBLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C) +C***KEYWORDS BLAS, LINEAR ALGEBRA, TRIAD, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DA double precision scalar multiplier +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C DY double precision vector with N elements +C INCY storage spacing between elements of DY +C +C --Output-- +C DY double precision result (unchanged if N .LE. 0) +C +C Overwrite double precision DY with double precision DA*DX + DY. +C For I = 0 to N-1, replace DY(LY+I*INCY) with DA*DX(LX+I*INCX) + +C DY(LY+I*INCY), +C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is +C defined in a similar way using INCY. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920310 Corrected definition of LX in DESCRIPTION. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DAXPY + DOUBLE PRECISION DX(*), DY(*), DA +C***FIRST EXECUTABLE STATEMENT DAXPY + IF (N.LE.0 .OR. DA.EQ.0.0D0) RETURN + IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 +C +C Code for unequal or nonpositive increments. +C + 5 IX = 1 + IY = 1 + IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 + IF (INCY .LT. 0) IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C Code for both increments equal to 1. +C +C Clean-up loop so remaining vector length is a multiple of 4. +C + 20 M = MOD(N,4) + IF (M .EQ. 0) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF (N .LT. 4) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I+1) = DY(I+1) + DA*DX(I+1) + DY(I+2) = DY(I+2) + DA*DX(I+2) + DY(I+3) = DY(I+3) + DA*DX(I+3) + 50 CONTINUE + RETURN +C +C Code for equal, positive, non-unit increments. +C + 60 NS = N*INCX + DO 70 I = 1,NS,INCX + DY(I) = DA*DX(I) + DY(I) + 70 CONTINUE + RETURN + END diff --git a/SLATEC/src/dbesi0.f b/SLATEC/src/dbesi0.f new file mode 100644 index 0000000..ef4e2c4 --- /dev/null +++ b/SLATEC/src/dbesi0.f @@ -0,0 +1,78 @@ +*DECK DBESI0 + DOUBLE PRECISION FUNCTION DBESI0 (X) +C***BEGIN PROLOGUE DBESI0 +C***PURPOSE Compute the hyperbolic Bessel function of the first kind +C of order zero. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B1 +C***TYPE DOUBLE PRECISION (BESI0-S, DBESI0-D) +C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBESI0(X) calculates the double precision modified (hyperbolic) +C Bessel function of the first kind of order zero and double +C precision argument X. +C +C Series for BI0 on the interval 0. to 9.00000E+00 +C with weighted error 9.51E-34 +C log weighted error 33.02 +C significant figures required 33.31 +C decimal places required 33.65 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DBSI0E, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DBESI0 + DOUBLE PRECISION X, BI0CS(18), XMAX, XSML, Y, D1MACH, + 1 DCSEVL, DBSI0E + LOGICAL FIRST + SAVE BI0CS, NTI0, XSML, XMAX, FIRST + DATA BI0CS( 1) / -.7660547252 8391449510 8189497624 3285 D-1 / + DATA BI0CS( 2) / +.1927337953 9938082699 5240875088 1196 D+1 / + DATA BI0CS( 3) / +.2282644586 9203013389 3702929233 0415 D+0 / + DATA BI0CS( 4) / +.1304891466 7072904280 7933421069 1888 D-1 / + DATA BI0CS( 5) / +.4344270900 8164874513 7868268102 6107 D-3 / + DATA BI0CS( 6) / +.9422657686 0019346639 2317174411 8766 D-5 / + DATA BI0CS( 7) / +.1434006289 5106910799 6209187817 9957 D-6 / + DATA BI0CS( 8) / +.1613849069 6617490699 1541971999 4611 D-8 / + DATA BI0CS( 9) / +.1396650044 5356696994 9509270814 2522 D-10 / + DATA BI0CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13 / + DATA BI0CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15 / + DATA BI0CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17 / + DATA BI0CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20 / + DATA BI0CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22 / + DATA BI0CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25 / + DATA BI0CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27 / + DATA BI0CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30 / + DATA BI0CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBESI0 + IF (FIRST) THEN + NTI0 = INITDS (BI0CS, 18, 0.1*REAL(D1MACH(3))) + XSML = SQRT(4.5D0*D1MACH(3)) + XMAX = LOG (D1MACH(2)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBESI0 = 1.0D0 + IF (Y.GT.XSML) DBESI0 = 2.75D0 + DCSEVL (Y*Y/4.5D0-1.D0, BI0CS, + 1 NTI0) + RETURN +C + 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESI0', + + 'ABS(X) SO BIG I0 OVERFLOWS', 2, 2) +C + DBESI0 = EXP(Y) * DBSI0E(X) +C + RETURN + END diff --git a/SLATEC/src/dbesj0.f b/SLATEC/src/dbesj0.f new file mode 100644 index 0000000..4d4a007 --- /dev/null +++ b/SLATEC/src/dbesj0.f @@ -0,0 +1,73 @@ +*DECK DBESJ0 + DOUBLE PRECISION FUNCTION DBESJ0 (X) +C***BEGIN PROLOGUE DBESJ0 +C***PURPOSE Compute the Bessel function of the first kind of order +C zero. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10A1 +C***TYPE DOUBLE PRECISION (BESJ0-S, DBESJ0-D) +C***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBESJ0(X) calculates the double precision Bessel function of +C the first kind of order zero for double precision argument X. +C +C Series for BJ0 on the interval 0. to 1.60000E+01 +C with weighted error 4.39E-32 +C log weighted error 31.36 +C significant figures required 31.21 +C decimal places required 32.00 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, D9B0MP, DCSEVL, INITDS +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE DBESJ0 + DOUBLE PRECISION X, BJ0CS(19), AMPL, THETA, XSML, Y, D1MACH, + 1 DCSEVL + LOGICAL FIRST + SAVE BJ0CS, NTJ0, XSML, FIRST + DATA BJ0CS( 1) / +.1002541619 6893913701 0731272640 74 D+0 / + DATA BJ0CS( 2) / -.6652230077 6440513177 6787578311 24 D+0 / + DATA BJ0CS( 3) / +.2489837034 9828131370 4604687266 80 D+0 / + DATA BJ0CS( 4) / -.3325272317 0035769653 8843415038 54 D-1 / + DATA BJ0CS( 5) / +.2311417930 4694015462 9049241177 29 D-2 / + DATA BJ0CS( 6) / -.9911277419 9508092339 0485193365 49 D-4 / + DATA BJ0CS( 7) / +.2891670864 3998808884 7339037470 78 D-5 / + DATA BJ0CS( 8) / -.6121085866 3032635057 8184074815 16 D-7 / + DATA BJ0CS( 9) / +.9838650793 8567841324 7687486364 15 D-9 / + DATA BJ0CS( 10) / -.1242355159 7301765145 5158970068 36 D-10 / + DATA BJ0CS( 11) / +.1265433630 2559045797 9158272103 63 D-12 / + DATA BJ0CS( 12) / -.1061945649 5287244546 9148175129 59 D-14 / + DATA BJ0CS( 13) / +.7470621075 8024567437 0989155840 00 D-17 / + DATA BJ0CS( 14) / -.4469703227 4412780547 6270079999 99 D-19 / + DATA BJ0CS( 15) / +.2302428158 4337436200 5230933333 33 D-21 / + DATA BJ0CS( 16) / -.1031914479 4166698148 5226666666 66 D-23 / + DATA BJ0CS( 17) / +.4060817827 4873322700 8000000000 00 D-26 / + DATA BJ0CS( 18) / -.1414383600 5240913919 9999999999 99 D-28 / + DATA BJ0CS( 19) / +.4391090549 6698880000 0000000000 00 D-31 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBESJ0 + IF (FIRST) THEN + NTJ0 = INITDS (BJ0CS, 19, 0.1*REAL(D1MACH(3))) + XSML = SQRT(8.0D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.4.0D0) GO TO 20 +C + DBESJ0 = 1.0D0 + IF (Y.GT.XSML) DBESJ0 = DCSEVL (.125D0*Y*Y-1.D0, BJ0CS, NTJ0) + RETURN +C + 20 CALL D9B0MP (Y, AMPL, THETA) + DBESJ0 = AMPL * COS(THETA) +C + RETURN + END diff --git a/SLATEC/src/dbesj1.f b/SLATEC/src/dbesj1.f new file mode 100644 index 0000000..c6ef17f --- /dev/null +++ b/SLATEC/src/dbesj1.f @@ -0,0 +1,82 @@ +*DECK DBESJ1 + DOUBLE PRECISION FUNCTION DBESJ1 (X) +C***BEGIN PROLOGUE DBESJ1 +C***PURPOSE Compute the Bessel function of the first kind of order one. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10A1 +C***TYPE DOUBLE PRECISION (BESJ1-S, DBESJ1-D) +C***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBESJ1(X) calculates the double precision Bessel function of the +C first kind of order one for double precision argument X. +C +C Series for BJ1 on the interval 0. to 1.60000E+01 +C with weighted error 1.16E-33 +C log weighted error 32.93 +C significant figures required 32.36 +C decimal places required 33.57 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, D9B1MP, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 780601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 910401 Corrected error in code which caused values to have the +C wrong sign for arguments less than 4.0. (WRB) +C***END PROLOGUE DBESJ1 + DOUBLE PRECISION X, BJ1CS(19), AMPL, THETA, XSML, XMIN, Y, + 1 D1MACH, DCSEVL + LOGICAL FIRST + SAVE BJ1CS, NTJ1, XSML, XMIN, FIRST + DATA BJ1CS( 1) / -.1172614151 3332786560 6240574524 003 D+0 / + DATA BJ1CS( 2) / -.2536152183 0790639562 3030884554 698 D+0 / + DATA BJ1CS( 3) / +.5012708098 4469568505 3656363203 743 D-1 / + DATA BJ1CS( 4) / -.4631514809 6250819184 2619728789 772 D-2 / + DATA BJ1CS( 5) / +.2479962294 1591402453 9124064592 364 D-3 / + DATA BJ1CS( 6) / -.8678948686 2788258452 1246435176 416 D-5 / + DATA BJ1CS( 7) / +.2142939171 4379369150 2766250991 292 D-6 / + DATA BJ1CS( 8) / -.3936093079 1831797922 9322764073 061 D-8 / + DATA BJ1CS( 9) / +.5591182317 9468800401 8248059864 032 D-10 / + DATA BJ1CS( 10) / -.6327616404 6613930247 7695274014 880 D-12 / + DATA BJ1CS( 11) / +.5840991610 8572470032 6945563268 266 D-14 / + DATA BJ1CS( 12) / -.4482533818 7012581903 9135059199 999 D-16 / + DATA BJ1CS( 13) / +.2905384492 6250246630 6018688000 000 D-18 / + DATA BJ1CS( 14) / -.1611732197 8414416541 2118186666 666 D-20 / + DATA BJ1CS( 15) / +.7739478819 3927463729 8346666666 666 D-23 / + DATA BJ1CS( 16) / -.3248693782 1119984114 3466666666 666 D-25 / + DATA BJ1CS( 17) / +.1202237677 2274102272 0000000000 000 D-27 / + DATA BJ1CS( 18) / -.3952012212 6513493333 3333333333 333 D-30 / + DATA BJ1CS( 19) / +.1161678082 2664533333 3333333333 333 D-32 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBESJ1 + IF (FIRST) THEN + NTJ1 = INITDS (BJ1CS, 19, 0.1*REAL(D1MACH(3))) +C + XSML = SQRT(8.0D0*D1MACH(3)) + XMIN = 2.0D0*D1MACH(1) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.4.0D0) GO TO 20 +C + DBESJ1 = 0.0D0 + IF (Y.EQ.0.0D0) RETURN + IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'DBESJ1', + + 'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1) + IF (Y.GT.XMIN) DBESJ1 = 0.5D0*X + IF (Y.GT.XSML) DBESJ1 = X*(.25D0 + DCSEVL (.125D0*Y*Y-1.D0, + 1 BJ1CS, NTJ1) ) + RETURN +C + 20 CALL D9B1MP (Y, AMPL, THETA) + DBESJ1 = SIGN (AMPL, X) * COS(THETA) +C + RETURN + END diff --git a/SLATEC/src/dbesk0.f b/SLATEC/src/dbesk0.f new file mode 100644 index 0000000..99d61e8 --- /dev/null +++ b/SLATEC/src/dbesk0.f @@ -0,0 +1,83 @@ +*DECK DBESK0 + DOUBLE PRECISION FUNCTION DBESK0 (X) +C***BEGIN PROLOGUE DBESK0 +C***PURPOSE Compute the modified (hyperbolic) Bessel function of the +C third kind of order zero. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B1 +C***TYPE DOUBLE PRECISION (BESK0-S, DBESK0-D) +C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, +C THIRD KIND +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBESK0(X) calculates the double precision modified (hyperbolic) +C Bessel function of the third kind of order zero for double +C precision argument X. The argument must be greater than zero +C but not so large that the result underflows. +C +C Series for BK0 on the interval 0. to 4.00000E+00 +C with weighted error 3.08E-33 +C log weighted error 32.51 +C significant figures required 32.05 +C decimal places required 33.11 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DBESI0, DBSK0E, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DBESK0 + DOUBLE PRECISION X, BK0CS(16), XMAX, XMAXT, XSML, Y, + 1 D1MACH, DCSEVL, DBESI0, DBSK0E + LOGICAL FIRST + SAVE BK0CS, NTK0, XSML, XMAX, FIRST + DATA BK0CS( 1) / -.3532739323 3902768720 1140060063 153 D-1 / + DATA BK0CS( 2) / +.3442898999 2462848688 6344927529 213 D+0 / + DATA BK0CS( 3) / +.3597993651 5361501626 5721303687 231 D-1 / + DATA BK0CS( 4) / +.1264615411 4469259233 8479508673 447 D-2 / + DATA BK0CS( 5) / +.2286212103 1194517860 8269830297 585 D-4 / + DATA BK0CS( 6) / +.2534791079 0261494573 0790013428 354 D-6 / + DATA BK0CS( 7) / +.1904516377 2202088589 7214059381 366 D-8 / + DATA BK0CS( 8) / +.1034969525 7633624585 1008317853 089 D-10 / + DATA BK0CS( 9) / +.4259816142 7910825765 2445327170 133 D-13 / + DATA BK0CS( 10) / +.1374465435 8807508969 4238325440 000 D-15 / + DATA BK0CS( 11) / +.3570896528 5083735909 9688597333 333 D-18 / + DATA BK0CS( 12) / +.7631643660 1164373766 7498666666 666 D-21 / + DATA BK0CS( 13) / +.1365424988 4407818590 8053333333 333 D-23 / + DATA BK0CS( 14) / +.2075275266 9066680831 9999999999 999 D-26 / + DATA BK0CS( 15) / +.2712814218 0729856000 0000000000 000 D-29 / + DATA BK0CS( 16) / +.3082593887 9146666666 6666666666 666 D-32 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBESK0 + IF (FIRST) THEN + NTK0 = INITDS (BK0CS, 16, 0.1*REAL(D1MACH(3))) + XSML = SQRT(4.0D0*D1MACH(3)) + XMAXT = -LOG(D1MACH(1)) + XMAX = XMAXT - 0.5D0*XMAXT*LOG(XMAXT)/(XMAXT+0.5D0) + ENDIF + FIRST = .FALSE. +C + IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESK0', + + 'X IS ZERO OR NEGATIVE', 2, 2) + IF (X.GT.2.0D0) GO TO 20 +C + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBESK0 = -LOG(0.5D0*X)*DBESI0(X) - 0.25D0 + DCSEVL (.5D0*Y-1.D0, + 1 BK0CS, NTK0) + RETURN +C + 20 DBESK0 = 0.D0 + IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESK0', + + 'X SO BIG K0 UNDERFLOWS', 1, 1) + IF (X.GT.XMAX) RETURN +C + DBESK0 = EXP(-X) * DBSK0E(X) +C + RETURN + END diff --git a/SLATEC/src/dbint4.f b/SLATEC/src/dbint4.f new file mode 100644 index 0000000..9e239de --- /dev/null +++ b/SLATEC/src/dbint4.f @@ -0,0 +1,241 @@ +*DECK DBINT4 + SUBROUTINE DBINT4 (X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNTOPT, T, + + BCOEF, N, K, W) +C***BEGIN PROLOGUE DBINT4 +C***PURPOSE Compute the B-representation of a cubic spline +C which interpolates given data. +C***LIBRARY SLATEC +C***CATEGORY E1A +C***TYPE DOUBLE PRECISION (BINT4-S, DBINT4-D) +C***KEYWORDS B-SPLINE, CUBIC SPLINES, DATA FITTING, INTERPOLATION +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Abstract **** a double precision routine **** +C +C DBINT4 computes the B representation (T,BCOEF,N,K) of a +C cubic spline (K=4) which interpolates data (X(I),Y(I)), +C I=1,NDATA. Parameters IBCL, IBCR, FBCL, FBCR allow the +C specification of the spline first or second derivative at +C both X(1) and X(NDATA). When this data is not specified +C by the problem, it is common practice to use a natural +C spline by setting second derivatives at X(1) and X(NDATA) +C to zero (IBCL=IBCR=2,FBCL=FBCR=0.0). The spline is defined +C on T(4) .LE. X .LE. T(N+1) with (ordered) interior knots at +C X(I) values where N=NDATA+2. The knots T(1),T(2),T(3) lie to +C the left of T(4)=X(1) and the knots T(N+2), T(N+3), T(N+4) +C lie to the right of T(N+1)=X(NDATA) in increasing order. If +C no extrapolation outside (X(1),X(NDATA)) is anticipated, the +C knots T(1)=T(2)=T(3)=T(4)=X(1) and T(N+2)=T(N+3)=T(N+4)= +C T(N+1)=X(NDATA) can be specified by KNTOPT=1. KNTOPT=2 +C selects a knot placement for T(1), T(2), T(3) to make the +C first 7 knots symmetric about T(4)=X(1) and similarly for +C T(N+2), T(N+3), T(N+4) about T(N+1)=X(NDATA). KNTOPT=3 +C allows the user to make his own selection, in increasing +C order, for T(1), T(2), T(3) to the left of X(1) and T(N+2), +C T(N+3), T(N+4) to the right of X(NDATA) in the work array +C W(1) through W(6). In any case, the interpolation on +C T(4) .LE. X .LE. T(N+1) by using function DBVALU is unique +C for given boundary conditions. +C +C Description of Arguments +C +C Input X,Y,FBCL,FBCR,W are double precision +C X - X vector of abscissae of length NDATA, distinct +C and in increasing order +C Y - Y vector of ordinates of length NDATA +C NDATA - number of data points, NDATA .GE. 2 +C IBCL - selection parameter for left boundary condition +C IBCL = 1 constrain the first derivative at +C X(1) to FBCL +C = 2 constrain the second derivative at +C X(1) to FBCL +C IBCR - selection parameter for right boundary condition +C IBCR = 1 constrain first derivative at +C X(NDATA) to FBCR +C IBCR = 2 constrain second derivative at +C X(NDATA) to FBCR +C FBCL - left boundary values governed by IBCL +C FBCR - right boundary values governed by IBCR +C KNTOPT - knot selection parameter +C KNTOPT = 1 sets knot multiplicity at T(4) and +C T(N+1) to 4 +C = 2 sets a symmetric placement of knots +C about T(4) and T(N+1) +C = 3 sets T(I)=W(I) and T(N+1+I)=W(3+I),I=1,3 +C where W(I),I=1,6 is supplied by the user +C W - work array of dimension at least 5*(NDATA+2) +C If KNTOPT=3, then W(1),W(2),W(3) are knot values to +C the left of X(1) and W(4),W(5),W(6) are knot +C values to the right of X(NDATA) in increasing +C order to be supplied by the user +C +C Output T,BCOEF are double precision +C T - knot array of length N+4 +C BCOEF - B spline coefficient array of length N +C N - number of coefficients, N=NDATA+2 +C K - order of spline, K=4 +C +C Error Conditions +C Improper input is a fatal error +C Singular system of equations is a fatal error +C +C***REFERENCES D. E. Amos, Computation with splines and B-splines, +C Report SAND78-1968, Sandia Laboratories, March 1979. +C Carl de Boor, Package for calculating with B-splines, +C SIAM Journal on Numerical Analysis 14, 3 (June 1977), +C pp. 441-472. +C Carl de Boor, A Practical Guide to Splines, Applied +C Mathematics Series 27, Springer-Verlag, New York, +C 1978. +C***ROUTINES CALLED D1MACH, DBNFAC, DBNSLV, DBSPVD, XERMSG +C***REVISION HISTORY (YYMMDD) +C 800901 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBINT4 +C + INTEGER I, IBCL, IBCR, IFLAG, ILB, ILEFT, IT, IUB, IW, IWP, J, + 1 JW, K, KNTOPT, N, NDATA, NDM, NP, NWROW + DOUBLE PRECISION BCOEF,FBCL,FBCR,T,TOL,TXN,TX1,VNIKX,W,WDTOL, + 1 WORK,X,XL,Y + DOUBLE PRECISION D1MACH + DIMENSION X(*), Y(*), T(*), BCOEF(*), W(5,*), VNIKX(4,4), WORK(15) +C***FIRST EXECUTABLE STATEMENT DBINT4 + WDTOL = D1MACH(4) + TOL = SQRT(WDTOL) + IF (NDATA.LT.2) GO TO 200 + NDM = NDATA - 1 + DO 10 I=1,NDM + IF (X(I).GE.X(I+1)) GO TO 210 + 10 CONTINUE + IF (IBCL.LT.1 .OR. IBCL.GT.2) GO TO 220 + IF (IBCR.LT.1 .OR. IBCR.GT.2) GO TO 230 + IF (KNTOPT.LT.1 .OR. KNTOPT.GT.3) GO TO 240 + K = 4 + N = NDATA + 2 + NP = N + 1 + DO 20 I=1,NDATA + T(I+3) = X(I) + 20 CONTINUE + GO TO (30, 50, 90), KNTOPT +C SET UP KNOT ARRAY WITH MULTIPLICITY 4 AT X(1) AND X(NDATA) + 30 CONTINUE + DO 40 I=1,3 + T(4-I) = X(1) + T(NP+I) = X(NDATA) + 40 CONTINUE + GO TO 110 +C SET UP KNOT ARRAY WITH SYMMETRIC PLACEMENT ABOUT END POINTS + 50 CONTINUE + IF (NDATA.GT.3) GO TO 70 + XL = (X(NDATA)-X(1))/3.0D0 + DO 60 I=1,3 + T(4-I) = T(5-I) - XL + T(NP+I) = T(NP+I-1) + XL + 60 CONTINUE + GO TO 110 + 70 CONTINUE + TX1 = X(1) + X(1) + TXN = X(NDATA) + X(NDATA) + DO 80 I=1,3 + T(4-I) = TX1 - X(I+1) + T(NP+I) = TXN - X(NDATA-I) + 80 CONTINUE + GO TO 110 +C SET UP KNOT ARRAY LESS THAN X(1) AND GREATER THAN X(NDATA) TO BE +C SUPPLIED BY USER IN WORK LOCATIONS W(1) THROUGH W(6) WHEN KNTOPT=3 + 90 CONTINUE + DO 100 I=1,3 + T(4-I) = W(4-I,1) + JW = MAX(1,I-1) + IW = MOD(I+2,5)+1 + T(NP+I) = W(IW,JW) + IF (T(4-I).GT.T(5-I)) GO TO 250 + IF (T(NP+I).LT.T(NP+I-1)) GO TO 250 + 100 CONTINUE + 110 CONTINUE +C + DO 130 I=1,5 + DO 120 J=1,N + W(I,J) = 0.0D0 + 120 CONTINUE + 130 CONTINUE +C SET UP LEFT INTERPOLATION POINT AND LEFT BOUNDARY CONDITION FOR +C RIGHT LIMITS + IT = IBCL + 1 + CALL DBSPVD(T, K, IT, X(1), K, 4, VNIKX, WORK) + IW = 0 + IF (ABS(VNIKX(3,1)).LT.TOL) IW = 1 + DO 140 J=1,3 + W(J+1,4-J) = VNIKX(4-J,IT) + W(J,4-J) = VNIKX(4-J,1) + 140 CONTINUE + BCOEF(1) = Y(1) + BCOEF(2) = FBCL +C SET UP INTERPOLATION EQUATIONS FOR POINTS I=2 TO I=NDATA-1 + ILEFT = 4 + IF (NDM.LT.2) GO TO 170 + DO 160 I=2,NDM + ILEFT = ILEFT + 1 + CALL DBSPVD(T, K, 1, X(I), ILEFT, 4, VNIKX, WORK) + DO 150 J=1,3 + W(J+1,3+I-J) = VNIKX(4-J,1) + 150 CONTINUE + BCOEF(I+1) = Y(I) + 160 CONTINUE +C SET UP RIGHT INTERPOLATION POINT AND RIGHT BOUNDARY CONDITION FOR +C LEFT LIMITS(ILEFT IS ASSOCIATED WITH T(N)=X(NDATA-1)) + 170 CONTINUE + IT = IBCR + 1 + CALL DBSPVD(T, K, IT, X(NDATA), ILEFT, 4, VNIKX, WORK) + JW = 0 + IF (ABS(VNIKX(2,1)).LT.TOL) JW = 1 + DO 180 J=1,3 + W(J+1,3+NDATA-J) = VNIKX(5-J,IT) + W(J+2,3+NDATA-J) = VNIKX(5-J,1) + 180 CONTINUE + BCOEF(N-1) = FBCR + BCOEF(N) = Y(NDATA) +C SOLVE SYSTEM OF EQUATIONS + ILB = 2 - JW + IUB = 2 - IW + NWROW = 5 + IWP = IW + 1 + CALL DBNFAC(W(IWP,1), NWROW, N, ILB, IUB, IFLAG) + IF (IFLAG.EQ.2) GO TO 190 + CALL DBNSLV(W(IWP,1), NWROW, N, ILB, IUB, BCOEF) + RETURN +C +C + 190 CONTINUE + CALL XERMSG ('SLATEC', 'DBINT4', + + 'THE SYSTEM OF EQUATIONS IS SINGULAR', 2, 1) + RETURN + 200 CONTINUE + CALL XERMSG ('SLATEC', 'DBINT4', 'NDATA IS LESS THAN 2', 2, 1) + RETURN + 210 CONTINUE + CALL XERMSG ('SLATEC', 'DBINT4', + + 'X VALUES ARE NOT DISTINCT OR NOT ORDERED', 2, 1) + RETURN + 220 CONTINUE + CALL XERMSG ('SLATEC', 'DBINT4', 'IBCL IS NOT 1 OR 2', 2, 1) + RETURN + 230 CONTINUE + CALL XERMSG ('SLATEC', 'DBINT4', 'IBCR IS NOT 1 OR 2', 2, 1) + RETURN + 240 CONTINUE + CALL XERMSG ('SLATEC', 'DBINT4', 'KNTOPT IS NOT 1, 2, OR 3', 2, + + 1) + RETURN + 250 CONTINUE + CALL XERMSG ('SLATEC', 'DBINT4', + + 'KNOT INPUT THROUGH W ARRAY IS NOT ORDERED PROPERLY', 2, 1) + RETURN + END diff --git a/SLATEC/src/dbnfac.f b/SLATEC/src/dbnfac.f new file mode 100644 index 0000000..eb61515 --- /dev/null +++ b/SLATEC/src/dbnfac.f @@ -0,0 +1,139 @@ +*DECK DBNFAC + SUBROUTINE DBNFAC (W, NROWW, NROW, NBANDL, NBANDU, IFLAG) +C***BEGIN PROLOGUE DBNFAC +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBINT4 and DBINTK +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (BNFAC-S, DBNFAC-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C DBNFAC is the BANFAC routine from +C * A Practical Guide to Splines * by C. de Boor +C +C DBNFAC is a double precision routine +C +C Returns in W the LU-factorization (without pivoting) of the banded +C matrix A of order NROW with (NBANDL + 1 + NBANDU) bands or diag- +C onals in the work array W . +C +C ***** I N P U T ****** W is double precision +C W.....Work array of size (NROWW,NROW) containing the interesting +C part of a banded matrix A , with the diagonals or bands of A +C stored in the rows of W , while columns of A correspond to +C columns of W . This is the storage mode used in LINPACK and +C results in efficient innermost loops. +C Explicitly, A has NBANDL bands below the diagonal +C + 1 (main) diagonal +C + NBANDU bands above the diagonal +C and thus, with MIDDLE = NBANDU + 1, +C A(I+J,J) is in W(I+MIDDLE,J) for I=-NBANDU,...,NBANDL +C J=1,...,NROW . +C For example, the interesting entries of A (1,2)-banded matrix +C of order 9 would appear in the first 1+1+2 = 4 rows of W +C as follows. +C 13 24 35 46 57 68 79 +C 12 23 34 45 56 67 78 89 +C 11 22 33 44 55 66 77 88 99 +C 21 32 43 54 65 76 87 98 +C +C All other entries of W not identified in this way with an en- +C try of A are never referenced . +C NROWW.....Row dimension of the work array W . +C must be .GE. NBANDL + 1 + NBANDU . +C NBANDL.....Number of bands of A below the main diagonal +C NBANDU.....Number of bands of A above the main diagonal . +C +C ***** O U T P U T ****** W is double precision +C IFLAG.....Integer indicating success( = 1) or failure ( = 2) . +C If IFLAG = 1, then +C W.....contains the LU-factorization of A into a unit lower triangu- +C lar matrix L and an upper triangular matrix U (both banded) +C and stored in customary fashion over the corresponding entries +C of A . This makes it possible to solve any particular linear +C system A*X = B for X by a +C CALL DBNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B ) +C with the solution X contained in B on return . +C If IFLAG = 2, then +C one of NROW-1, NBANDL,NBANDU failed to be nonnegative, or else +C one of the potential pivots was found to be zero indicating +C that A does not have an LU-factorization. This implies that +C A is singular in case it is totally positive . +C +C ***** M E T H O D ****** +C Gauss elimination W I T H O U T pivoting is used. The routine is +C intended for use with matrices A which do not require row inter- +C changes during factorization, especially for the T O T A L L Y +C P O S I T I V E matrices which occur in spline calculations. +C The routine should NOT be used for an arbitrary banded matrix. +C +C***SEE ALSO DBINT4, DBINTK +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 800901 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE DBNFAC +C + INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K, + 1 KMAX, MIDDLE, MIDMK, NROWM1 + DOUBLE PRECISION W(NROWW,*), FACTOR, PIVOT +C +C***FIRST EXECUTABLE STATEMENT DBNFAC + IFLAG = 1 + MIDDLE = NBANDU + 1 +C W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF A . + NROWM1 = NROW - 1 + IF (NROWM1) 120, 110, 10 + 10 IF (NBANDL.GT.0) GO TO 30 +C A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO . + DO 20 I=1,NROWM1 + IF (W(MIDDLE,I).EQ.0.0D0) GO TO 120 + 20 CONTINUE + GO TO 110 + 30 IF (NBANDU.GT.0) GO TO 60 +C A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND +C DIVIDE EACH COLUMN BY ITS DIAGONAL . + DO 50 I=1,NROWM1 + PIVOT = W(MIDDLE,I) + IF (PIVOT.EQ.0.0D0) GO TO 120 + JMAX = MIN(NBANDL,NROW-I) + DO 40 J=1,JMAX + W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT + 40 CONTINUE + 50 CONTINUE + RETURN +C +C A IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION + 60 DO 100 I=1,NROWM1 +C W(MIDDLE,I) IS PIVOT FOR I-TH STEP . + PIVOT = W(MIDDLE,I) + IF (PIVOT.EQ.0.0D0) GO TO 120 +C JMAX IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN I +C BELOW THE DIAGONAL . + JMAX = MIN(NBANDL,NROW-I) +C DIVIDE EACH ENTRY IN COLUMN I BELOW DIAGONAL BY PIVOT . + DO 70 J=1,JMAX + W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT + 70 CONTINUE +C KMAX IS THE NUMBER OF (NONZERO) ENTRIES IN ROW I TO +C THE RIGHT OF THE DIAGONAL . + KMAX = MIN(NBANDU,NROW-I) +C SUBTRACT A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN +C (BELOW ROW I ) . + DO 90 K=1,KMAX + IPK = I + K + MIDMK = MIDDLE - K + FACTOR = W(MIDMK,IPK) + DO 80 J=1,JMAX + W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE +C CHECK THE LAST DIAGONAL ENTRY . + 110 IF (W(MIDDLE,NROW).NE.0.0D0) RETURN + 120 IFLAG = 2 + RETURN + END diff --git a/SLATEC/src/dbnslv.f b/SLATEC/src/dbnslv.f new file mode 100644 index 0000000..2bae84b --- /dev/null +++ b/SLATEC/src/dbnslv.f @@ -0,0 +1,81 @@ +*DECK DBNSLV + SUBROUTINE DBNSLV (W, NROWW, NROW, NBANDL, NBANDU, B) +C***BEGIN PROLOGUE DBNSLV +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBINT4 and DBINTK +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (BNSLV-S, DBNSLV-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C DBNSLV is the BANSLV routine from +C * A Practical Guide to Splines * by C. de Boor +C +C DBNSLV is a double precision routine +C +C Companion routine to DBNFAC . It returns the solution X of the +C linear system A*X = B in place of B , given the LU-factorization +C for A in the work array W from DBNFAC. +C +C ***** I N P U T ****** W,B are DOUBLE PRECISION +C W, NROWW,NROW,NBANDL,NBANDU.....Describe the LU-factorization of a +C banded matrix A of order NROW as constructed in DBNFAC . +C For details, see DBNFAC . +C B.....Right side of the system to be solved . +C +C ***** O U T P U T ****** B is DOUBLE PRECISION +C B.....Contains the solution X , of order NROW . +C +C ***** M E T H O D ****** +C (With A = L*U, as stored in W,) the unit lower triangular system +C L(U*X) = B is solved for Y = U*X, and Y stored in B . Then the +C upper triangular system U*X = Y is solved for X . The calcul- +C ations are so arranged that the innermost loops stay within columns. +C +C***SEE ALSO DBINT4, DBINTK +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 800901 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE DBNSLV +C + INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1 + DOUBLE PRECISION W(NROWW,*), B(*) +C***FIRST EXECUTABLE STATEMENT DBNSLV + MIDDLE = NBANDU + 1 + IF (NROW.EQ.1) GO TO 80 + NROWM1 = NROW - 1 + IF (NBANDL.EQ.0) GO TO 30 +C FORWARD PASS +C FOR I=1,2,...,NROW-1, SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN +C OF L ) FROM RIGHT SIDE (BELOW I-TH ROW) . + DO 20 I=1,NROWM1 + JMAX = MIN(NBANDL,NROW-I) + DO 10 J=1,JMAX + B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I) + 10 CONTINUE + 20 CONTINUE +C BACKWARD PASS +C FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG- +C ONAL ENTRY OF U, THEN SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN +C OF U) FROM RIGHT SIDE (ABOVE I-TH ROW). + 30 IF (NBANDU.GT.0) GO TO 50 +C A IS LOWER TRIANGULAR . + DO 40 I=1,NROW + B(I) = B(I)/W(1,I) + 40 CONTINUE + RETURN + 50 I = NROW + 60 B(I) = B(I)/W(MIDDLE,I) + JMAX = MIN(NBANDU,I-1) + DO 70 J=1,JMAX + B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I) + 70 CONTINUE + I = I - 1 + IF (I.GT.1) GO TO 60 + 80 B(1) = B(1)/W(MIDDLE,1) + RETURN + END diff --git a/SLATEC/src/dbsi0e.f b/SLATEC/src/dbsi0e.f new file mode 100644 index 0000000..441f933 --- /dev/null +++ b/SLATEC/src/dbsi0e.f @@ -0,0 +1,208 @@ +*DECK DBSI0E + DOUBLE PRECISION FUNCTION DBSI0E (X) +C***BEGIN PROLOGUE DBSI0E +C***PURPOSE Compute the exponentially scaled modified (hyperbolic) +C Bessel function of the first kind of order zero. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B1 +C***TYPE DOUBLE PRECISION (BESI0E-S, DBSI0E-D) +C***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, +C HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, +C ORDER ZERO, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBSI0E(X) calculates the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the first kind of order +C zero for double precision argument X. The result is the Bessel +C function I0(X) multiplied by EXP(-ABS(X)). +C +C Series for BI0 on the interval 0. to 9.00000E+00 +C with weighted error 9.51E-34 +C log weighted error 33.02 +C significant figures required 33.31 +C decimal places required 33.65 +C +C Series for AI0 on the interval 1.25000E-01 to 3.33333E-01 +C with weighted error 2.74E-32 +C log weighted error 31.56 +C significant figures required 30.15 +C decimal places required 32.39 +C +C Series for AI02 on the interval 0. to 1.25000E-01 +C with weighted error 1.97E-32 +C log weighted error 31.71 +C significant figures required 30.15 +C decimal places required 32.63 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, INITDS +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE DBSI0E + DOUBLE PRECISION X, BI0CS(18), AI0CS(46), AI02CS(69), + 1 XSML, Y, D1MACH, DCSEVL + LOGICAL FIRST + SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02, XSML, FIRST + DATA BI0CS( 1) / -.7660547252 8391449510 8189497624 3285 D-1 / + DATA BI0CS( 2) / +.1927337953 9938082699 5240875088 1196 D+1 / + DATA BI0CS( 3) / +.2282644586 9203013389 3702929233 0415 D+0 / + DATA BI0CS( 4) / +.1304891466 7072904280 7933421069 1888 D-1 / + DATA BI0CS( 5) / +.4344270900 8164874513 7868268102 6107 D-3 / + DATA BI0CS( 6) / +.9422657686 0019346639 2317174411 8766 D-5 / + DATA BI0CS( 7) / +.1434006289 5106910799 6209187817 9957 D-6 / + DATA BI0CS( 8) / +.1613849069 6617490699 1541971999 4611 D-8 / + DATA BI0CS( 9) / +.1396650044 5356696994 9509270814 2522 D-10 / + DATA BI0CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13 / + DATA BI0CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15 / + DATA BI0CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17 / + DATA BI0CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20 / + DATA BI0CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22 / + DATA BI0CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25 / + DATA BI0CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27 / + DATA BI0CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30 / + DATA BI0CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33 / + DATA AI0CS( 1) / +.7575994494 0237959427 2987203743 8 D-1 / + DATA AI0CS( 2) / +.7591380810 8233455072 9297873320 4 D-2 / + DATA AI0CS( 3) / +.4153131338 9237505018 6319749138 2 D-3 / + DATA AI0CS( 4) / +.1070076463 4390730735 8242970217 0 D-4 / + DATA AI0CS( 5) / -.7901179979 2128946607 5031948573 0 D-5 / + DATA AI0CS( 6) / -.7826143501 4387522697 8898980690 9 D-6 / + DATA AI0CS( 7) / +.2783849942 9488708063 8118538985 7 D-6 / + DATA AI0CS( 8) / +.8252472600 6120271919 6682913319 8 D-8 / + DATA AI0CS( 9) / -.1204463945 5201991790 5496089110 3 D-7 / + DATA AI0CS( 10) / +.1559648598 5060764436 1228752792 8 D-8 / + DATA AI0CS( 11) / +.2292556367 1033165434 7725480285 7 D-9 / + DATA AI0CS( 12) / -.1191622884 2790646036 7777423447 8 D-9 / + DATA AI0CS( 13) / +.1757854916 0324098302 1833124774 3 D-10 / + DATA AI0CS( 14) / +.1128224463 2189005171 4441135682 4 D-11 / + DATA AI0CS( 15) / -.1146848625 9272988777 2963387698 2 D-11 / + DATA AI0CS( 16) / +.2715592054 8036628726 4365192160 6 D-12 / + DATA AI0CS( 17) / -.2415874666 5626878384 4247572028 1 D-13 / + DATA AI0CS( 18) / -.6084469888 2551250646 0609963922 4 D-14 / + DATA AI0CS( 19) / +.3145705077 1754772937 0836026730 3 D-14 / + DATA AI0CS( 20) / -.7172212924 8711877179 6217505917 6 D-15 / + DATA AI0CS( 21) / +.7874493403 4541033960 8390960332 7 D-16 / + DATA AI0CS( 22) / +.1004802753 0094624023 4524457183 9 D-16 / + DATA AI0CS( 23) / -.7566895365 3505348534 2843588881 0 D-17 / + DATA AI0CS( 24) / +.2150380106 8761198878 1205128784 5 D-17 / + DATA AI0CS( 25) / -.3754858341 8308744291 5158445260 8 D-18 / + DATA AI0CS( 26) / +.2354065842 2269925769 0075710532 2 D-19 / + DATA AI0CS( 27) / +.1114667612 0479285302 2637335511 0 D-19 / + DATA AI0CS( 28) / -.5398891884 3969903786 9677932270 9 D-20 / + DATA AI0CS( 29) / +.1439598792 2407526770 4285840452 2 D-20 / + DATA AI0CS( 30) / -.2591916360 1110934064 6081840196 2 D-21 / + DATA AI0CS( 31) / +.2238133183 9985839074 3409229824 0 D-22 / + DATA AI0CS( 32) / +.5250672575 3647711727 7221683199 9 D-23 / + DATA AI0CS( 33) / -.3249904138 5332307841 7343228586 6 D-23 / + DATA AI0CS( 34) / +.9924214103 2050379278 5728471040 0 D-24 / + DATA AI0CS( 35) / -.2164992254 2446695231 4655429973 3 D-24 / + DATA AI0CS( 36) / +.3233609471 9435940839 7333299199 9 D-25 / + DATA AI0CS( 37) / -.1184620207 3967424898 2473386666 6 D-26 / + DATA AI0CS( 38) / -.1281671853 9504986505 4833868799 9 D-26 / + DATA AI0CS( 39) / +.5827015182 2793905116 0556885333 3 D-27 / + DATA AI0CS( 40) / -.1668222326 0261097193 6450150399 9 D-27 / + DATA AI0CS( 41) / +.3625309510 5415699757 0068480000 0 D-28 / + DATA AI0CS( 42) / -.5733627999 0557135899 4595839999 9 D-29 / + DATA AI0CS( 43) / +.3736796722 0630982296 4258133333 3 D-30 / + DATA AI0CS( 44) / +.1602073983 1568519633 6551253333 3 D-30 / + DATA AI0CS( 45) / -.8700424864 0572298845 2249599999 9 D-31 / + DATA AI0CS( 46) / +.2741320937 9374811456 0341333333 3 D-31 / + DATA AI02CS( 1) / +.5449041101 4108831607 8960962268 0 D-1 / + DATA AI02CS( 2) / +.3369116478 2556940898 9785662979 9 D-2 / + DATA AI02CS( 3) / +.6889758346 9168239842 6263914301 1 D-4 / + DATA AI02CS( 4) / +.2891370520 8347564829 6692402323 2 D-5 / + DATA AI02CS( 5) / +.2048918589 4690637418 2760534093 1 D-6 / + DATA AI02CS( 6) / +.2266668990 4981780645 9327743136 1 D-7 / + DATA AI02CS( 7) / +.3396232025 7083863451 5084396952 3 D-8 / + DATA AI02CS( 8) / +.4940602388 2249695891 0482449783 5 D-9 / + DATA AI02CS( 9) / +.1188914710 7846438342 4084525196 3 D-10 / + DATA AI02CS( 10) / -.3149916527 9632413645 3864862961 9 D-10 / + DATA AI02CS( 11) / -.1321581184 0447713118 7540739926 7 D-10 / + DATA AI02CS( 12) / -.1794178531 5068061177 7943574026 9 D-11 / + DATA AI02CS( 13) / +.7180124451 3836662336 7106429346 9 D-12 / + DATA AI02CS( 14) / +.3852778382 7421427011 4089801777 6 D-12 / + DATA AI02CS( 15) / +.1540086217 5214098269 1325823339 7 D-13 / + DATA AI02CS( 16) / -.4150569347 2872220866 2689972015 6 D-13 / + DATA AI02CS( 17) / -.9554846698 8283076487 0214494312 5 D-14 / + DATA AI02CS( 18) / +.3811680669 3526224207 4605535511 8 D-14 / + DATA AI02CS( 19) / +.1772560133 0565263836 0493266675 8 D-14 / + DATA AI02CS( 20) / -.3425485619 6772191346 1924790328 2 D-15 / + DATA AI02CS( 21) / -.2827623980 5165834849 4205593759 4 D-15 / + DATA AI02CS( 22) / +.3461222867 6974610930 9706250813 4 D-16 / + DATA AI02CS( 23) / +.4465621420 2967599990 1042054284 3 D-16 / + DATA AI02CS( 24) / -.4830504485 9441820712 5525403795 4 D-17 / + DATA AI02CS( 25) / -.7233180487 8747539545 6227240924 5 D-17 / + DATA AI02CS( 26) / +.9921475412 1736985988 8046093981 0 D-18 / + DATA AI02CS( 27) / +.1193650890 8459820855 0439949924 2 D-17 / + DATA AI02CS( 28) / -.2488709837 1508072357 2054491660 2 D-18 / + DATA AI02CS( 29) / -.1938426454 1609059289 8469781132 6 D-18 / + DATA AI02CS( 30) / +.6444656697 3734438687 8301949394 9 D-19 / + DATA AI02CS( 31) / +.2886051596 2892243264 8171383073 4 D-19 / + DATA AI02CS( 32) / -.1601954907 1749718070 6167156200 7 D-19 / + DATA AI02CS( 33) / -.3270815010 5923147208 9193567485 9 D-20 / + DATA AI02CS( 34) / +.3686932283 8264091811 4600723939 3 D-20 / + DATA AI02CS( 35) / +.1268297648 0309501530 1359529710 9 D-22 / + DATA AI02CS( 36) / -.7549825019 3772739076 9636664410 1 D-21 / + DATA AI02CS( 37) / +.1502133571 3778353496 3712789053 4 D-21 / + DATA AI02CS( 38) / +.1265195883 5096485349 3208799248 3 D-21 / + DATA AI02CS( 39) / -.6100998370 0836807086 2940891600 2 D-22 / + DATA AI02CS( 40) / -.1268809629 2601282643 6872095924 2 D-22 / + DATA AI02CS( 41) / +.1661016099 8907414578 4038487490 5 D-22 / + DATA AI02CS( 42) / -.1585194335 7658855793 7970504881 4 D-23 / + DATA AI02CS( 43) / -.3302645405 9682178009 5381766755 6 D-23 / + DATA AI02CS( 44) / +.1313580902 8392397817 4039623117 4 D-23 / + DATA AI02CS( 45) / +.3689040246 6711567933 1425637280 4 D-24 / + DATA AI02CS( 46) / -.4210141910 4616891492 1978247249 9 D-24 / + DATA AI02CS( 47) / +.4791954591 0828657806 3171401373 0 D-25 / + DATA AI02CS( 48) / +.8459470390 2218217952 9971707412 4 D-25 / + DATA AI02CS( 49) / -.4039800940 8728324931 4607937181 0 D-25 / + DATA AI02CS( 50) / -.6434714653 6504313473 0100850469 5 D-26 / + DATA AI02CS( 51) / +.1225743398 8756659903 4464736990 5 D-25 / + DATA AI02CS( 52) / -.2934391316 0257089231 9879821175 4 D-26 / + DATA AI02CS( 53) / -.1961311309 1949829262 0371205728 9 D-26 / + DATA AI02CS( 54) / +.1503520374 8221934241 6229900309 8 D-26 / + DATA AI02CS( 55) / -.9588720515 7448265520 3386388206 9 D-28 / + DATA AI02CS( 56) / -.3483339380 8170454863 9441108511 4 D-27 / + DATA AI02CS( 57) / +.1690903610 2630436730 6244960725 6 D-27 / + DATA AI02CS( 58) / +.1982866538 7356030438 9400115718 8 D-28 / + DATA AI02CS( 59) / -.5317498081 4918162145 7583002528 4 D-28 / + DATA AI02CS( 60) / +.1803306629 8883929462 3501450390 1 D-28 / + DATA AI02CS( 61) / +.6213093341 4548931758 8405311242 2 D-29 / + DATA AI02CS( 62) / -.7692189292 7721618632 0072806673 0 D-29 / + DATA AI02CS( 63) / +.1858252826 1117025426 2556016596 3 D-29 / + DATA AI02CS( 64) / +.1237585142 2813957248 9927154554 1 D-29 / + DATA AI02CS( 65) / -.1102259120 4092238032 1779478779 2 D-29 / + DATA AI02CS( 66) / +.1886287118 0397044900 7787447943 1 D-30 / + DATA AI02CS( 67) / +.2160196872 2436589131 4903141406 0 D-30 / + DATA AI02CS( 68) / -.1605454124 9197432005 8446594965 5 D-30 / + DATA AI02CS( 69) / +.1965352984 5942906039 3884807331 8 D-31 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBSI0E + IF (FIRST) THEN + ETA = 0.1*REAL(D1MACH(3)) + NTI0 = INITDS (BI0CS, 18, ETA) + NTAI0 = INITDS (AI0CS, 46, ETA) + NTAI02 = INITDS (AI02CS, 69, ETA) + XSML = SQRT(4.5D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBSI0E = 1.0D0 - X + IF (Y.GT.XSML) DBSI0E = EXP(-Y) * (2.75D0 + + 1 DCSEVL (Y*Y/4.5D0-1.D0, BI0CS, NTI0) ) + RETURN +C + 20 IF (Y.LE.8.D0) DBSI0E = (0.375D0 + DCSEVL ((48.D0/Y-11.D0)/5.D0, + 1 AI0CS, NTAI0))/SQRT(Y) + IF (Y.GT.8.D0) DBSI0E = (0.375D0 + DCSEVL (16.D0/Y-1.D0, AI02CS, + 1 NTAI02))/SQRT(Y) +C + RETURN + END diff --git a/SLATEC/src/dbsk0e.f b/SLATEC/src/dbsk0e.f new file mode 100644 index 0000000..28dc5f1 --- /dev/null +++ b/SLATEC/src/dbsk0e.f @@ -0,0 +1,164 @@ +*DECK DBSK0E + DOUBLE PRECISION FUNCTION DBSK0E (X) +C***BEGIN PROLOGUE DBSK0E +C***PURPOSE Compute the exponentially scaled modified (hyperbolic) +C Bessel function of the third kind of order zero. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B1 +C***TYPE DOUBLE PRECISION (BESK0E-S, DBSK0E-D) +C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, +C THIRD KIND +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBSK0E(X) computes the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the third kind of +C order zero for positive double precision argument X. +C +C Series for BK0 on the interval 0. to 4.00000E+00 +C with weighted error 3.08E-33 +C log weighted error 32.51 +C significant figures required 32.05 +C decimal places required 33.11 +C +C Series for AK0 on the interval 1.25000E-01 to 5.00000E-01 +C with weighted error 2.85E-32 +C log weighted error 31.54 +C significant figures required 30.19 +C decimal places required 32.33 +C +C Series for AK02 on the interval 0. to 1.25000E-01 +C with weighted error 2.30E-32 +C log weighted error 31.64 +C significant figures required 29.68 +C decimal places required 32.40 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DBESI0, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770701 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE DBSK0E + DOUBLE PRECISION X, BK0CS(16), AK0CS(38), AK02CS(33), + 1 XSML, Y, D1MACH, DCSEVL, DBESI0 + LOGICAL FIRST + SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST + DATA BK0CS( 1) / -.3532739323 3902768720 1140060063 153 D-1 / + DATA BK0CS( 2) / +.3442898999 2462848688 6344927529 213 D+0 / + DATA BK0CS( 3) / +.3597993651 5361501626 5721303687 231 D-1 / + DATA BK0CS( 4) / +.1264615411 4469259233 8479508673 447 D-2 / + DATA BK0CS( 5) / +.2286212103 1194517860 8269830297 585 D-4 / + DATA BK0CS( 6) / +.2534791079 0261494573 0790013428 354 D-6 / + DATA BK0CS( 7) / +.1904516377 2202088589 7214059381 366 D-8 / + DATA BK0CS( 8) / +.1034969525 7633624585 1008317853 089 D-10 / + DATA BK0CS( 9) / +.4259816142 7910825765 2445327170 133 D-13 / + DATA BK0CS( 10) / +.1374465435 8807508969 4238325440 000 D-15 / + DATA BK0CS( 11) / +.3570896528 5083735909 9688597333 333 D-18 / + DATA BK0CS( 12) / +.7631643660 1164373766 7498666666 666 D-21 / + DATA BK0CS( 13) / +.1365424988 4407818590 8053333333 333 D-23 / + DATA BK0CS( 14) / +.2075275266 9066680831 9999999999 999 D-26 / + DATA BK0CS( 15) / +.2712814218 0729856000 0000000000 000 D-29 / + DATA BK0CS( 16) / +.3082593887 9146666666 6666666666 666 D-32 / + DATA AK0CS( 1) / -.7643947903 3279414240 8297827008 8 D-1 / + DATA AK0CS( 2) / -.2235652605 6998190520 2309555079 1 D-1 / + DATA AK0CS( 3) / +.7734181154 6938582353 0061817404 7 D-3 / + DATA AK0CS( 4) / -.4281006688 8860994644 5214643541 6 D-4 / + DATA AK0CS( 5) / +.3081700173 8629747436 5001482666 0 D-5 / + DATA AK0CS( 6) / -.2639367222 0096649740 6744889272 3 D-6 / + DATA AK0CS( 7) / +.2563713036 4034692062 9408826574 2 D-7 / + DATA AK0CS( 8) / -.2742705549 9002012638 5721191524 4 D-8 / + DATA AK0CS( 9) / +.3169429658 0974995920 8083287340 3 D-9 / + DATA AK0CS( 10) / -.3902353286 9621841416 0106571796 2 D-10 / + DATA AK0CS( 11) / +.5068040698 1885754020 5009212728 6 D-11 / + DATA AK0CS( 12) / -.6889574741 0078706795 4171355798 4 D-12 / + DATA AK0CS( 13) / +.9744978497 8259176913 8820133683 1 D-13 / + DATA AK0CS( 14) / -.1427332841 8845485053 8985534012 2 D-13 / + DATA AK0CS( 15) / +.2156412571 0214630395 5806297652 7 D-14 / + DATA AK0CS( 16) / -.3349654255 1495627721 8878205853 0 D-15 / + DATA AK0CS( 17) / +.5335260216 9529116921 4528039260 1 D-16 / + DATA AK0CS( 18) / -.8693669980 8907538076 3962237883 7 D-17 / + DATA AK0CS( 19) / +.1446404347 8622122278 8776344234 6 D-17 / + DATA AK0CS( 20) / -.2452889825 5001296824 0467875157 3 D-18 / + DATA AK0CS( 21) / +.4233754526 2321715728 2170634240 0 D-19 / + DATA AK0CS( 22) / -.7427946526 4544641956 9534129493 3 D-20 / + DATA AK0CS( 23) / +.1323150529 3926668662 7796746240 0 D-20 / + DATA AK0CS( 24) / -.2390587164 7396494513 3598146559 9 D-21 / + DATA AK0CS( 25) / +.4376827585 9232261401 6571255466 6 D-22 / + DATA AK0CS( 26) / -.8113700607 3451180593 3901141333 3 D-23 / + DATA AK0CS( 27) / +.1521819913 8321729583 1037815466 6 D-23 / + DATA AK0CS( 28) / -.2886041941 4833977702 3595861333 3 D-24 / + DATA AK0CS( 29) / +.5530620667 0547179799 9261013333 3 D-25 / + DATA AK0CS( 30) / -.1070377329 2498987285 9163306666 6 D-25 / + DATA AK0CS( 31) / +.2091086893 1423843002 9632853333 3 D-26 / + DATA AK0CS( 32) / -.4121713723 6462038274 1026133333 3 D-27 / + DATA AK0CS( 33) / +.8193483971 1213076401 3568000000 0 D-28 / + DATA AK0CS( 34) / -.1642000275 4592977267 8075733333 3 D-28 / + DATA AK0CS( 35) / +.3316143281 4802271958 9034666666 6 D-29 / + DATA AK0CS( 36) / -.6746863644 1452959410 8586666666 6 D-30 / + DATA AK0CS( 37) / +.1382429146 3184246776 3541333333 3 D-30 / + DATA AK0CS( 38) / -.2851874167 3598325708 1173333333 3 D-31 / + DATA AK02CS( 1) / -.1201869826 3075922398 3934621245 2 D-1 / + DATA AK02CS( 2) / -.9174852691 0256953106 5256107571 3 D-2 / + DATA AK02CS( 3) / +.1444550931 7750058210 4884387805 7 D-3 / + DATA AK02CS( 4) / -.4013614175 4357097286 7102107787 9 D-5 / + DATA AK02CS( 5) / +.1567831810 8523106725 9034899033 3 D-6 / + DATA AK02CS( 6) / -.7770110438 5217377103 1579975446 0 D-8 / + DATA AK02CS( 7) / +.4611182576 1797178825 3313052958 6 D-9 / + DATA AK02CS( 8) / -.3158592997 8605657705 2666580330 9 D-10 / + DATA AK02CS( 9) / +.2435018039 3650411278 3588781432 9 D-11 / + DATA AK02CS( 10) / -.2074331387 3983478977 0985337350 6 D-12 / + DATA AK02CS( 11) / +.1925787280 5899170847 4273650469 3 D-13 / + DATA AK02CS( 12) / -.1927554805 8389561036 0034718221 8 D-14 / + DATA AK02CS( 13) / +.2062198029 1978182782 8523786964 4 D-15 / + DATA AK02CS( 14) / -.2341685117 5792424026 0364019507 1 D-16 / + DATA AK02CS( 15) / +.2805902810 6430422468 1517882845 8 D-17 / + DATA AK02CS( 16) / -.3530507631 1618079458 1548246357 3 D-18 / + DATA AK02CS( 17) / +.4645295422 9351082674 2421633706 6 D-19 / + DATA AK02CS( 18) / -.6368625941 3442664739 2205346133 3 D-20 / + DATA AK02CS( 19) / +.9069521310 9865155676 2234880000 0 D-21 / + DATA AK02CS( 20) / -.1337974785 4236907398 4500531199 9 D-21 / + DATA AK02CS( 21) / +.2039836021 8599523155 2208896000 0 D-22 / + DATA AK02CS( 22) / -.3207027481 3678405000 6086997333 3 D-23 / + DATA AK02CS( 23) / +.5189744413 6623099636 2635946666 6 D-24 / + DATA AK02CS( 24) / -.8629501497 5405721929 6460799999 9 D-25 / + DATA AK02CS( 25) / +.1472161183 1025598552 0803840000 0 D-25 / + DATA AK02CS( 26) / -.2573069023 8670112838 1235199999 9 D-26 / + DATA AK02CS( 27) / +.4601774086 6435165873 7664000000 0 D-27 / + DATA AK02CS( 28) / -.8411555324 2010937371 3066666666 6 D-28 / + DATA AK02CS( 29) / +.1569806306 6353689393 0154666666 6 D-28 / + DATA AK02CS( 30) / -.2988226453 0057577889 7919999999 9 D-29 / + DATA AK02CS( 31) / +.5796831375 2168365206 1866666666 6 D-30 / + DATA AK02CS( 32) / -.1145035994 3476813321 5573333333 3 D-30 / + DATA AK02CS( 33) / +.2301266594 2496828020 0533333333 3 D-31 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBSK0E + IF (FIRST) THEN + ETA = 0.1*REAL(D1MACH(3)) + NTK0 = INITDS (BK0CS, 16, ETA) + NTAK0 = INITDS (AK0CS, 38, ETA) + NTAK02 = INITDS (AK02CS, 33, ETA) + XSML = SQRT(4.0D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBSK0E', + + 'X IS ZERO OR NEGATIVE', 2, 2) + IF (X.GT.2.0D0) GO TO 20 +C + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBSK0E = EXP(X)*(-LOG(0.5D0*X)*DBESI0(X) - 0.25D0 + + 1 DCSEVL (.5D0*Y-1.D0, BK0CS, NTK0)) + RETURN +C + 20 IF (X.LE.8.D0) DBSK0E = (1.25D0 + DCSEVL ((16.D0/X-5.D0)/3.D0, + 1 AK0CS, NTAK0))/SQRT(X) + IF (X.GT.8.D0) DBSK0E = (1.25D0 + + 1 DCSEVL (16.D0/X-1.D0, AK02CS, NTAK02))/SQRT(X) +C + RETURN + END diff --git a/SLATEC/src/dbspvd.f b/SLATEC/src/dbspvd.f new file mode 100644 index 0000000..99a8fba --- /dev/null +++ b/SLATEC/src/dbspvd.f @@ -0,0 +1,162 @@ +*DECK DBSPVD + SUBROUTINE DBSPVD (T, K, NDERIV, X, ILEFT, LDVNIK, VNIKX, WORK) +C***BEGIN PROLOGUE DBSPVD +C***PURPOSE Calculate the value and all derivatives of order less than +C NDERIV of all basis functions which do not vanish at X. +C***LIBRARY SLATEC +C***CATEGORY E3, K6 +C***TYPE DOUBLE PRECISION (BSPVD-S, DBSPVD-D) +C***KEYWORDS DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Written by Carl de Boor and modified by D. E. Amos +C +C Abstract **** a double precision routine **** +C +C DBSPVD is the BSPLVD routine of the reference. +C +C DBSPVD calculates the value and all derivatives of order +C less than NDERIV of all basis functions which do not +C (possibly) vanish at X. ILEFT is input such that +C T(ILEFT) .LE. X .LT. T(ILEFT+1). A call to INTRV(T,N+1,X, +C ILO,ILEFT,MFLAG) will produce the proper ILEFT. The output of +C DBSPVD is a matrix VNIKX(I,J) of dimension at least (K,NDERIV) +C whose columns contain the K nonzero basis functions and +C their NDERIV-1 right derivatives at X, I=1,K, J=1,NDERIV. +C These basis functions have indices ILEFT-K+I, I=1,K, +C K .LE. ILEFT .LE. N. The nonzero part of the I-th basis +C function lies in (T(I),T(I+K)), I=1,N). +C +C If X=T(ILEFT+1) then VNIKX contains left limiting values +C (left derivatives) at T(ILEFT+1). In particular, ILEFT = N +C produces left limiting values at the right end point +C X=T(N+1). To obtain left limiting values at T(I), I=K+1,N+1, +C set X= next lower distinct knot, call INTRV to get ILEFT, +C set X=T(I), and then call DBSPVD. +C +C Description of Arguments +C Input T,X are double precision +C T - knot vector of length N+K, where +C N = number of B-spline basis functions +C N = sum of knot multiplicities-K +C K - order of the B-spline, K .GE. 1 +C NDERIV - number of derivatives = NDERIV-1, +C 1 .LE. NDERIV .LE. K +C X - argument of basis functions, +C T(K) .LE. X .LE. T(N+1) +C ILEFT - largest integer such that +C T(ILEFT) .LE. X .LT. T(ILEFT+1) +C LDVNIK - leading dimension of matrix VNIKX +C +C Output VNIKX,WORK are double precision +C VNIKX - matrix of dimension at least (K,NDERIV) contain- +C ing the nonzero basis functions at X and their +C derivatives columnwise. +C WORK - a work vector of length (K+1)*(K+2)/2 +C +C Error Conditions +C Improper input is a fatal error +C +C***REFERENCES Carl de Boor, Package for calculating with B-splines, +C SIAM Journal on Numerical Analysis 14, 3 (June 1977), +C pp. 441-472. +C***ROUTINES CALLED DBSPVN, XERMSG +C***REVISION HISTORY (YYMMDD) +C 800901 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBSPVD +C + INTEGER I,IDERIV,ILEFT,IPKMD,J,JJ,JLOW,JM,JP1MID,K,KMD, KP1, L, + 1 LDUMMY, M, MHIGH, NDERIV + DOUBLE PRECISION FACTOR, FKMD, T, V, VNIKX, WORK, X +C DIMENSION T(ILEFT+K), WORK((K+1)*(K+2)/2) +C A(I,J) = WORK(I+J*(J+1)/2), I=1,J+1 J=1,K-1 +C A(I,K) = W0RK(I+K*(K-1)/2) I=1.K +C WORK(1) AND WORK((K+1)*(K+2)/2) ARE NOT USED. + DIMENSION T(*), VNIKX(LDVNIK,*), WORK(*) +C***FIRST EXECUTABLE STATEMENT DBSPVD + IF(K.LT.1) GO TO 200 + IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 205 + IF(LDVNIK.LT.K) GO TO 210 + IDERIV = NDERIV + KP1 = K + 1 + JJ = KP1 - IDERIV + CALL DBSPVN(T, JJ, K, 1, X, ILEFT, VNIKX, WORK, IWORK) + IF (IDERIV.EQ.1) GO TO 100 + MHIGH = IDERIV + DO 20 M=2,MHIGH + JP1MID = 1 + DO 10 J=IDERIV,K + VNIKX(J,IDERIV) = VNIKX(JP1MID,1) + JP1MID = JP1MID + 1 + 10 CONTINUE + IDERIV = IDERIV - 1 + JJ = KP1 - IDERIV + CALL DBSPVN(T, JJ, K, 2, X, ILEFT, VNIKX, WORK, IWORK) + 20 CONTINUE +C + JM = KP1*(KP1+1)/2 + DO 30 L = 1,JM + WORK(L) = 0.0D0 + 30 CONTINUE +C A(I,I) = WORK(I*(I+3)/2) = 1.0 I = 1,K + L = 2 + J = 0 + DO 40 I = 1,K + J = J + L + WORK(J) = 1.0D0 + L = L + 1 + 40 CONTINUE + KMD = K + DO 90 M=2,MHIGH + KMD = KMD - 1 + FKMD = KMD + I = ILEFT + J = K + JJ = J*(J+1)/2 + JM = JJ - J + DO 60 LDUMMY=1,KMD + IPKMD = I + KMD + FACTOR = FKMD/(T(IPKMD)-T(I)) + DO 50 L=1,J + WORK(L+JJ) = (WORK(L+JJ)-WORK(L+JM))*FACTOR + 50 CONTINUE + I = I - 1 + J = J - 1 + JJ = JM + JM = JM - J + 60 CONTINUE +C + DO 80 I=1,K + V = 0.0D0 + JLOW = MAX(I,M) + JJ = JLOW*(JLOW+1)/2 + DO 70 J=JLOW,K + V = WORK(I+JJ)*VNIKX(J,M) + V + JJ = JJ + J + 1 + 70 CONTINUE + VNIKX(I,M) = V + 80 CONTINUE + 90 CONTINUE + 100 RETURN +C +C + 200 CONTINUE + CALL XERMSG ('SLATEC', 'DBSPVD', 'K DOES NOT SATISFY K.GE.1', 2, + + 1) + RETURN + 205 CONTINUE + CALL XERMSG ('SLATEC', 'DBSPVD', + + 'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1) + RETURN + 210 CONTINUE + CALL XERMSG ('SLATEC', 'DBSPVD', + + 'LDVNIK DOES NOT SATISFY LDVNIK.GE.K', 2, 1) + RETURN + END diff --git a/SLATEC/src/dbspvn.f b/SLATEC/src/dbspvn.f new file mode 100644 index 0000000..027646f --- /dev/null +++ b/SLATEC/src/dbspvn.f @@ -0,0 +1,123 @@ +*DECK DBSPVN + SUBROUTINE DBSPVN (T, JHIGH, K, INDEX, X, ILEFT, VNIKX, WORK, + + IWORK) +C***BEGIN PROLOGUE DBSPVN +C***PURPOSE Calculate the value of all (possibly) nonzero basis +C functions at X. +C***LIBRARY SLATEC +C***CATEGORY E3, K6 +C***TYPE DOUBLE PRECISION (BSPVN-S, DBSPVN-D) +C***KEYWORDS EVALUATION OF B-SPLINE +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Written by Carl de Boor and modified by D. E. Amos +C +C Abstract **** a double precision routine **** +C DBSPVN is the BSPLVN routine of the reference. +C +C DBSPVN calculates the value of all (possibly) nonzero basis +C functions at X of order MAX(JHIGH,(J+1)*(INDEX-1)), where T(K) +C .LE. X .LE. T(N+1) and J=IWORK is set inside the routine on +C the first call when INDEX=1. ILEFT is such that T(ILEFT) .LE. +C X .LT. T(ILEFT+1). A call to DINTRV(T,N+1,X,ILO,ILEFT,MFLAG) +C produces the proper ILEFT. DBSPVN calculates using the basic +C algorithm needed in DBSPVD. If only basis functions are +C desired, setting JHIGH=K and INDEX=1 can be faster than +C calling DBSPVD, but extra coding is required for derivatives +C (INDEX=2) and DBSPVD is set up for this purpose. +C +C Left limiting values are set up as described in DBSPVD. +C +C Description of Arguments +C +C Input T,X are double precision +C T - knot vector of length N+K, where +C N = number of B-spline basis functions +C N = sum of knot multiplicities-K +C JHIGH - order of B-spline, 1 .LE. JHIGH .LE. K +C K - highest possible order +C INDEX - INDEX = 1 gives basis functions of order JHIGH +C = 2 denotes previous entry with work, IWORK +C values saved for subsequent calls to +C DBSPVN. +C X - argument of basis functions, +C T(K) .LE. X .LE. T(N+1) +C ILEFT - largest integer such that +C T(ILEFT) .LE. X .LT. T(ILEFT+1) +C +C Output VNIKX, WORK are double precision +C VNIKX - vector of length K for spline values. +C WORK - a work vector of length 2*K +C IWORK - a work parameter. Both WORK and IWORK contain +C information necessary to continue for INDEX = 2. +C When INDEX = 1 exclusively, these are scratch +C variables and can be used for other purposes. +C +C Error Conditions +C Improper input is a fatal error. +C +C***REFERENCES Carl de Boor, Package for calculating with B-splines, +C SIAM Journal on Numerical Analysis 14, 3 (June 1977), +C pp. 441-472. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 800901 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBSPVN +C + INTEGER ILEFT, IMJP1, INDEX, IPJ, IWORK, JHIGH, JP1, JP1ML, K, L + DOUBLE PRECISION T, VM, VMPREV, VNIKX, WORK, X +C DIMENSION T(ILEFT+JHIGH) + DIMENSION T(*), VNIKX(*), WORK(*) +C CONTENT OF J, DELTAM, DELTAP IS EXPECTED UNCHANGED BETWEEN CALLS. +C WORK(I) = DELTAP(I), WORK(K+I) = DELTAM(I), I = 1,K +C***FIRST EXECUTABLE STATEMENT DBSPVN + IF(K.LT.1) GO TO 90 + IF(JHIGH.GT.K .OR. JHIGH.LT.1) GO TO 100 + IF(INDEX.LT.1 .OR. INDEX.GT.2) GO TO 105 + IF(X.LT.T(ILEFT) .OR. X.GT.T(ILEFT+1)) GO TO 110 + GO TO (10, 20), INDEX + 10 IWORK = 1 + VNIKX(1) = 1.0D0 + IF (IWORK.GE.JHIGH) GO TO 40 +C + 20 IPJ = ILEFT + IWORK + WORK(IWORK) = T(IPJ) - X + IMJP1 = ILEFT - IWORK + 1 + WORK(K+IWORK) = X - T(IMJP1) + VMPREV = 0.0D0 + JP1 = IWORK + 1 + DO 30 L=1,IWORK + JP1ML = JP1 - L + VM = VNIKX(L)/(WORK(L)+WORK(K+JP1ML)) + VNIKX(L) = VM*WORK(L) + VMPREV + VMPREV = VM*WORK(K+JP1ML) + 30 CONTINUE + VNIKX(JP1) = VMPREV + IWORK = JP1 + IF (IWORK.LT.JHIGH) GO TO 20 +C + 40 RETURN +C +C + 90 CONTINUE + CALL XERMSG ('SLATEC', 'DBSPVN', 'K DOES NOT SATISFY K.GE.1', 2, + + 1) + RETURN + 100 CONTINUE + CALL XERMSG ('SLATEC', 'DBSPVN', + + 'JHIGH DOES NOT SATISFY 1.LE.JHIGH.LE.K', 2, 1) + RETURN + 105 CONTINUE + CALL XERMSG ('SLATEC', 'DBSPVN', 'INDEX IS NOT 1 OR 2', 2, 1) + RETURN + 110 CONTINUE + CALL XERMSG ('SLATEC', 'DBSPVN', + + 'X DOES NOT SATISFY T(ILEFT).LE.X.LE.T(ILEFT+1)', 2, 1) + RETURN + END diff --git a/SLATEC/src/dbvalu.f b/SLATEC/src/dbvalu.f new file mode 100644 index 0000000..26a8224 --- /dev/null +++ b/SLATEC/src/dbvalu.f @@ -0,0 +1,165 @@ +*DECK DBVALU + DOUBLE PRECISION FUNCTION DBVALU (T, A, N, K, IDERIV, X, INBV, + + WORK) +C***BEGIN PROLOGUE DBVALU +C***PURPOSE Evaluate the B-representation of a B-spline at X for the +C function value or any of its derivatives. +C***LIBRARY SLATEC +C***CATEGORY E3, K6 +C***TYPE DOUBLE PRECISION (BVALU-S, DBVALU-D) +C***KEYWORDS DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Written by Carl de Boor and modified by D. E. Amos +C +C Abstract **** a double precision routine **** +C DBVALU is the BVALUE function of the reference. +C +C DBVALU evaluates the B-representation (T,A,N,K) of a B-spline +C at X for the function value on IDERIV=0 or any of its +C derivatives on IDERIV=1,2,...,K-1. Right limiting values +C (right derivatives) are returned except at the right end +C point X=T(N+1) where left limiting values are computed. The +C spline is defined on T(K) .LE. X .LE. T(N+1). DBVALU returns +C a fatal error message when X is outside of this interval. +C +C To compute left derivatives or left limiting values at a +C knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1. +C +C DBVALU calls DINTRV +C +C Description of Arguments +C +C Input T,A,X are double precision +C T - knot vector of length N+K +C A - B-spline coefficient vector of length N +C N - number of B-spline coefficients +C N = sum of knot multiplicities-K +C K - order of the B-spline, K .GE. 1 +C IDERIV - order of the derivative, 0 .LE. IDERIV .LE. K-1 +C IDERIV = 0 returns the B-spline value +C X - argument, T(K) .LE. X .LE. T(N+1) +C INBV - an initialization parameter which must be set +C to 1 the first time DBVALU is called. +C +C Output WORK,DBVALU are double precision +C INBV - INBV contains information for efficient process- +C ing after the initial call and INBV must not +C be changed by the user. Distinct splines require +C distinct INBV parameters. +C WORK - work vector of length 3*K. +C DBVALU - value of the IDERIV-th derivative at X +C +C Error Conditions +C An improper input is a fatal error +C +C***REFERENCES Carl de Boor, Package for calculating with B-splines, +C SIAM Journal on Numerical Analysis 14, 3 (June 1977), +C pp. 441-472. +C***ROUTINES CALLED DINTRV, XERMSG +C***REVISION HISTORY (YYMMDD) +C 800901 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 890911 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBVALU +C + INTEGER I,IDERIV,IDERP1,IHI,IHMKMJ,ILO,IMK,IMKPJ, INBV, IPJ, + 1 IP1, IP1MJ, J, JJ, J1, J2, K, KMIDER, KMJ, KM1, KPK, MFLAG, N + DOUBLE PRECISION A, FKMJ, T, WORK, X + DIMENSION T(*), A(*), WORK(*) +C***FIRST EXECUTABLE STATEMENT DBVALU + DBVALU = 0.0D0 + IF(K.LT.1) GO TO 102 + IF(N.LT.K) GO TO 101 + IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 110 + KMIDER = K - IDERIV +C +C *** FIND *I* IN (K,N) SUCH THAT T(I) .LE. X .LT. T(I+1) +C (OR, .LE. T(I+1) IF T(I) .LT. T(I+1) = T(N+1)). + KM1 = K - 1 + CALL DINTRV(T, N+1, X, INBV, I, MFLAG) + IF (X.LT.T(K)) GO TO 120 + IF (MFLAG.EQ.0) GO TO 20 + IF (X.GT.T(I)) GO TO 130 + 10 IF (I.EQ.K) GO TO 140 + I = I - 1 + IF (X.EQ.T(I)) GO TO 10 +C +C *** DIFFERENCE THE COEFFICIENTS *IDERIV* TIMES +C WORK(I) = AJ(I), WORK(K+I) = DP(I), WORK(K+K+I) = DM(I), I=1.K +C + 20 IMK = I - K + DO 30 J=1,K + IMKPJ = IMK + J + WORK(J) = A(IMKPJ) + 30 CONTINUE + IF (IDERIV.EQ.0) GO TO 60 + DO 50 J=1,IDERIV + KMJ = K - J + FKMJ = KMJ + DO 40 JJ=1,KMJ + IHI = I + JJ + IHMKMJ = IHI - KMJ + WORK(JJ) = (WORK(JJ+1)-WORK(JJ))/(T(IHI)-T(IHMKMJ))*FKMJ + 40 CONTINUE + 50 CONTINUE +C +C *** COMPUTE VALUE AT *X* IN (T(I),(T(I+1)) OF IDERIV-TH DERIVATIVE, +C GIVEN ITS RELEVANT B-SPLINE COEFF. IN AJ(1),...,AJ(K-IDERIV). + 60 IF (IDERIV.EQ.KM1) GO TO 100 + IP1 = I + 1 + KPK = K + K + J1 = K + 1 + J2 = KPK + 1 + DO 70 J=1,KMIDER + IPJ = I + J + WORK(J1) = T(IPJ) - X + IP1MJ = IP1 - J + WORK(J2) = X - T(IP1MJ) + J1 = J1 + 1 + J2 = J2 + 1 + 70 CONTINUE + IDERP1 = IDERIV + 1 + DO 90 J=IDERP1,KM1 + KMJ = K - J + ILO = KMJ + DO 80 JJ=1,KMJ + WORK(JJ) = (WORK(JJ+1)*WORK(KPK+ILO)+WORK(JJ) + 1 *WORK(K+JJ))/(WORK(KPK+ILO)+WORK(K+JJ)) + ILO = ILO - 1 + 80 CONTINUE + 90 CONTINUE + 100 DBVALU = WORK(1) + RETURN +C +C + 101 CONTINUE + CALL XERMSG ('SLATEC', 'DBVALU', 'N DOES NOT SATISFY N.GE.K', 2, + + 1) + RETURN + 102 CONTINUE + CALL XERMSG ('SLATEC', 'DBVALU', 'K DOES NOT SATISFY K.GE.1', 2, + + 1) + RETURN + 110 CONTINUE + CALL XERMSG ('SLATEC', 'DBVALU', + + 'IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', 2, 1) + RETURN + 120 CONTINUE + CALL XERMSG ('SLATEC', 'DBVALU', + + 'X IS N0T GREATER THAN OR EQUAL TO T(K)', 2, 1) + RETURN + 130 CONTINUE + CALL XERMSG ('SLATEC', 'DBVALU', + + 'X IS NOT LESS THAN OR EQUAL TO T(N+1)', 2, 1) + RETURN + 140 CONTINUE + CALL XERMSG ('SLATEC', 'DBVALU', + + 'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1) + RETURN + END diff --git a/SLATEC/src/dcsevl.f b/SLATEC/src/dcsevl.f new file mode 100644 index 0000000..7cff406 --- /dev/null +++ b/SLATEC/src/dcsevl.f @@ -0,0 +1,65 @@ +*DECK DCSEVL + DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N) +C***BEGIN PROLOGUE DCSEVL +C***PURPOSE Evaluate a Chebyshev series. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C3A2 +C***TYPE DOUBLE PRECISION (CSEVL-S, DCSEVL-D) +C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Evaluate the N-term Chebyshev series CS at X. Adapted from +C a method presented in the paper by Broucke referenced below. +C +C Input Arguments -- +C X value at which the series is to be evaluated. +C CS array of N terms of a Chebyshev series. In evaluating +C CS, only half the first coefficient is summed. +C N number of terms in array CS. +C +C***REFERENCES R. Broucke, Ten subroutines for the manipulation of +C Chebyshev series, Algorithm 446, Communications of +C the A.C.M. 16, (1973) pp. 254-256. +C L. Fox and I. B. Parker, Chebyshev Polynomials in +C Numerical Analysis, Oxford University Press, 1968, +C page 56. +C***ROUTINES CALLED D1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770401 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900329 Prologued revised extensively and code rewritten to allow +C X to be slightly outside interval (-1,+1). (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DCSEVL + DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH + LOGICAL FIRST + SAVE FIRST, ONEPL + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DCSEVL + IF (FIRST) ONEPL = 1.0D0 + D1MACH(4) + FIRST = .FALSE. + IF (N .LT. 1) CALL XERMSG ('SLATEC', 'DCSEVL', + + 'NUMBER OF TERMS .LE. 0', 2, 2) + IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'DCSEVL', + + 'NUMBER OF TERMS .GT. 1000', 3, 2) + IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'DCSEVL', + + 'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1) +C + B1 = 0.0D0 + B0 = 0.0D0 + TWOX = 2.0D0*X + DO 10 I = 1,N + B2 = B1 + B1 = B0 + NI = N + 1 - I + B0 = TWOX*B1 - B2 + CS(NI) + 10 CONTINUE +C + DCSEVL = 0.5D0*(B0-B2) +C + RETURN + END diff --git a/SLATEC/src/ddeabm.f b/SLATEC/src/ddeabm.f new file mode 100644 index 0000000..dca92b6 --- /dev/null +++ b/SLATEC/src/ddeabm.f @@ -0,0 +1,688 @@ +*DECK DDEABM + SUBROUTINE DDEABM (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, + + RWORK, LRW, IWORK, LIW, RPAR, IPAR) +C***BEGIN PROLOGUE DDEABM +C***PURPOSE Solve an initial value problem in ordinary differential +C equations using an Adams-Bashforth method. +C***LIBRARY SLATEC (DEPAC) +C***CATEGORY I1A1B +C***TYPE DOUBLE PRECISION (DEABM-S, DDEABM-D) +C***KEYWORDS ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS, +C ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR +C***AUTHOR Shampine, L. F., (SNLA) +C Watts, H. A., (SNLA) +C***DESCRIPTION +C +C This is the Adams code in the package of differential equation +C solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. +C Design of the package was by L. F. Shampine and H. A. Watts. +C It is documented in +C SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE +C Solvers. +C DDEABM is a driver for a modification of the code ODE written by +C L. F. Shampine and M. K. Gordon +C Sandia Laboratories +C Albuquerque, New Mexico 87185 +C +C ********************************************************************** +C * ABSTRACT * +C ************ +C +C Subroutine DDEABM uses the Adams-Bashforth-Moulton +C Predictor-Corrector formulas of orders one through twelve to +C integrate a system of NEQ first order ordinary differential +C equations of the form +C DU/DX = DF(X,U) +C when the vector Y(*) of initial values for U(*) at X=T is given. +C The subroutine integrates from T to TOUT. It is easy to continue the +C integration to get results at additional TOUT. This is the interval +C mode of operation. It is also easy for the routine to return with +C the solution at each intermediate step on the way to TOUT. This is +C the intermediate-output mode of operation. +C +C DDEABM uses subprograms DDES, DSTEPS, DINTP, DHSTRT, DHVNRM, +C D1MACH, and the error handling routine XERMSG. The only machine +C dependent parameters to be assigned appear in D1MACH. +C +C ********************************************************************** +C * Description of The Arguments To DDEABM (An Overview) * +C ********************************************************************** +C +C The Parameters are +C +C DF -- This is the name of a subroutine which you provide to +C define the differential equations. +C +C NEQ -- This is the number of (first order) differential +C equations to be integrated. +C +C T -- This is a DOUBLE PRECISION value of the independent +C variable. +C +C Y(*) -- This DOUBLE PRECISION array contains the solution +C components at T. +C +C TOUT -- This is a DOUBLE PRECISION point at which a solution is +C desired. +C +C INFO(*) -- The basic task of the code is to integrate the +C differential equations from T to TOUT and return an +C answer at TOUT. INFO(*) is an INTEGER array which is used +C to communicate exactly how you want this task to be +C carried out. +C +C RTOL, ATOL -- These DOUBLE PRECISION quantities represent +C relative and absolute error tolerances which you +C provide to indicate how accurately you wish the +C solution to be computed. You may choose them to be +C both scalars or else both vectors. +C +C IDID -- This scalar quantity is an indicator reporting what +C the code did. You must monitor this INTEGER variable to +C decide what action to take next. +C +C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of +C length LRW which provides the code with needed storage +C space. +C +C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW +C which provides the code with needed storage space and an +C across call flag. +C +C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and the DF subroutine. +C +C Quantities which are used as input items are +C NEQ, T, Y(*), TOUT, INFO(*), +C RTOL, ATOL, RWORK(1), LRW and LIW. +C +C Quantities which may be altered by the code are +C T, Y(*), INFO(1), RTOL, ATOL, +C IDID, RWORK(*) and IWORK(*). +C +C ********************************************************************** +C * INPUT -- What To Do On The First Call To DDEABM * +C ********************************************************************** +C +C The first call of the code is defined to be the start of each new +C problem. Read through the descriptions of all the following items, +C provide sufficient storage space for designated arrays, set +C appropriate variables for the initialization of the problem, and +C give information about how you want the problem to be solved. +C +C +C DF -- Provide a subroutine of the form +C DF(X,U,UPRIME,RPAR,IPAR) +C to define the system of first order differential equations +C which is to be solved. For the given values of X and the +C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must +C evaluate the NEQ components of the system of differential +C equations DU/DX=DF(X,U) and store the derivatives in the +C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for +C equations I=1,...,NEQ. +C +C Subroutine DF must NOT alter X or U(*). You must declare +C the name df in an external statement in your program that +C calls DDEABM. You must dimension U and UPRIME in DF. +C +C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and subroutine DF. They are not used or +C altered by DDEABM. If you do not need RPAR or IPAR, +C ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension them in +C your calling program and in DF as arrays of appropriate +C length. +C +C NEQ -- Set it to the number of differential equations. +C (NEQ .GE. 1) +C +C T -- Set it to the initial point of the integration. +C You must use a program variable for T because the code +C changes its value. +C +C Y(*) -- Set this vector to the initial values of the NEQ solution +C components at the initial point. You must dimension Y at +C least NEQ in your calling program. +C +C TOUT -- Set it to the first point at which a solution +C is desired. You can take TOUT = T, in which case the code +C will evaluate the derivative of the solution at T and +C return. Integration either forward in T (TOUT .GT. T) or +C backward in T (TOUT .LT. T) is permitted. +C +C The code advances the solution from T to TOUT using +C step sizes which are automatically selected so as to +C achieve the desired accuracy. If you wish, the code will +C return with the solution and its derivative following +C each intermediate step (intermediate-output mode) so that +C you can monitor them, but you still must provide TOUT in +C accord with the basic aim of the code. +C +C The first step taken by the code is a critical one +C because it must reflect how fast the solution changes near +C the initial point. The code automatically selects an +C initial step size which is practically always suitable for +C the problem. By using the fact that the code will not step +C past TOUT in the first step, you could, if necessary, +C restrict the length of the initial step size. +C +C For some problems it may not be permissible to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP. When you have declared a TSTOP point (see INFO(4) +C and RWORK(1)), you have told the code not to integrate +C past TSTOP. In this case any TOUT beyond TSTOP is invalid +C input. +C +C INFO(*) -- Use the INFO array to give the code more details about +C how you want your problem solved. This array should be +C dimensioned of length 15 to accommodate other members of +C DEPAC or possible future extensions, though DDEABM uses +C only the first four entries. You must respond to all of +C the following items which are arranged as questions. The +C simplest use of the code corresponds to answering all +C questions as YES ,i.e. setting ALL entries of INFO to 0. +C +C INFO(1) -- This parameter enables the code to initialize +C itself. You must set it to indicate the start of every +C new problem. +C +C **** Is this the first call for this problem ... +C YES -- set INFO(1) = 0 +C NO -- not applicable here. +C See below for continuation calls. **** +C +C INFO(2) -- How much accuracy you want of your solution +C is specified by the error tolerances RTOL and ATOL. +C The simplest use is to take them both to be scalars. +C To obtain more flexibility, they can both be vectors. +C The code must be told your choice. +C +C **** Are both error tolerances RTOL, ATOL scalars ... +C YES -- set INFO(2) = 0 +C and input scalars for both RTOL and ATOL +C NO -- set INFO(2) = 1 +C and input arrays for both RTOL and ATOL **** +C +C INFO(3) -- The code integrates from T in the direction +C of TOUT by steps. If you wish, it will return the +C computed solution and derivative at the next +C intermediate step (the intermediate-output mode) or +C TOUT, whichever comes first. This is a good way to +C proceed if you want to see the behavior of the solution. +C If you must have solutions at a great many specific +C TOUT points, this code will compute them efficiently. +C +C **** Do you want the solution only at +C TOUT (and not at the next intermediate step) ... +C YES -- set INFO(3) = 0 +C NO -- set INFO(3) = 1 **** +C +C INFO(4) -- To handle solutions at a great many specific +C values TOUT efficiently, this code may integrate past +C TOUT and interpolate to obtain the result at TOUT. +C Sometimes it is not possible to integrate beyond some +C point TSTOP because the equation changes there or it is +C not defined past TSTOP. Then you must tell the code +C not to go past. +C +C **** Can the integration be carried out without any +C Restrictions on the independent variable T ... +C YES -- set INFO(4)=0 +C NO -- set INFO(4)=1 +C and define the stopping point TSTOP by +C setting RWORK(1)=TSTOP **** +C +C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) +C error tolerances to tell the code how accurately you want +C the solution to be computed. They must be defined as +C program variables because the code may change them. You +C have two choices -- +C Both RTOL and ATOL are scalars. (INFO(2)=0) +C Both RTOL and ATOL are vectors. (INFO(2)=1) +C In either case all components must be non-negative. +C +C The tolerances are used by the code in a local error test +C at each step which requires roughly that +C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL +C for each vector component. +C (More specifically, a Euclidean norm is used to measure +C the size of vectors, and the error test uses the magnitude +C of the solution at the beginning of the step.) +C +C The true (global) error is the difference between the true +C solution of the initial value problem and the computed +C approximation. Practically all present day codes, +C including this one, control the local error at each step +C and do not even attempt to control the global error +C directly. Roughly speaking, they produce a solution Y(T) +C which satisfies the differential equations with a +C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , +C and, almost always, R(T) is bounded by the error +C tolerances. Usually, but not always, the true accuracy of +C the computed Y is comparable to the error tolerances. This +C code will usually, but not always, deliver a more accurate +C solution if you reduce the tolerances and integrate again. +C By comparing two such solutions you can get a fairly +C reliable idea of the true error in the solution at the +C bigger tolerances. +C +C Setting ATOL=0.D0 results in a pure relative error test on +C that component. Setting RTOL=0. results in a pure absolute +C error test on that component. A mixed test with non-zero +C RTOL and ATOL corresponds roughly to a relative error +C test when the solution component is much bigger than ATOL +C and to an absolute error test when the solution component +C is smaller than the threshold ATOL. +C +C Proper selection of the absolute error control parameters +C ATOL requires you to have some idea of the scale of the +C solution components. To acquire this information may mean +C that you will have to solve the problem more than once. In +C the absence of scale information, you should ask for some +C relative accuracy in all the components (by setting RTOL +C values non-zero) and perhaps impose extremely small +C absolute error tolerances to protect against the danger of +C a solution component becoming zero. +C +C The code will not attempt to compute a solution at an +C accuracy unreasonable for the machine being used. It will +C advise you if you ask for too much accuracy and inform +C you as to the maximum accuracy it believes possible. +C +C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length +C LRW in your calling program. +C +C RWORK(1) -- If you have set INFO(4)=0, you can ignore this +C optional input parameter. Otherwise you must define a +C stopping point TSTOP by setting RWORK(1) = TSTOP. +C (for some problems it may not be permissible to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP.) +C +C LRW -- Set it to the declared length of the RWORK array. +C You must have LRW .GE. 130+21*NEQ +C +C IWORK(*) -- Dimension this INTEGER work array of length LIW in +C your calling program. +C +C LIW -- Set it to the declared length of the IWORK array. +C You must have LIW .GE. 51 +C +C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and +C INTEGER type, respectively. You can use them for +C communication between your program that calls DDEABM and +C the DF subroutine. They are not used or altered by +C DDEABM. If you do not need RPAR or IPAR, ignore these +C parameters by treating them as dummy arguments. If you do +C choose to use them, dimension them in your calling program +C and in DF as arrays of appropriate length. +C +C ********************************************************************** +C * OUTPUT -- After Any Return From DDEABM * +C ********************************************************************** +C +C The principal aim of the code is to return a computed solution at +C TOUT, although it is also possible to obtain intermediate results +C along the way. To find out whether the code achieved its goal +C or if the integration process was interrupted before the task was +C completed, you must check the IDID parameter. +C +C +C T -- The solution was successfully advanced to the +C output value of T. +C +C Y(*) -- Contains the computed solution approximation at T. +C You may also be interested in the approximate derivative +C of the solution at T. It is contained in +C RWORK(21),...,RWORK(20+NEQ). +C +C IDID -- Reports what the code did +C +C *** Task Completed *** +C Reported by positive values of IDID +C +C IDID = 1 -- A step was successfully taken in the +C intermediate-output mode. The code has not +C yet reached TOUT. +C +C IDID = 2 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping exactly to TOUT. +C +C IDID = 3 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping past TOUT. +C Y(*) is obtained by interpolation. +C +C *** Task Interrupted *** +C Reported by negative values of IDID +C +C IDID = -1 -- A large amount of work has been expended. +C (500 steps attempted) +C +C IDID = -2 -- The error tolerances are too stringent. +C +C IDID = -3 -- The local error test cannot be satisfied +C because you specified a zero component in ATOL +C and the corresponding computed solution +C component is zero. Thus, a pure relative error +C test is impossible for this component. +C +C IDID = -4 -- The problem appears to be stiff. +C +C IDID = -5,-6,-7,..,-32 -- Not applicable for this code +C but used by other members of DEPAC or possible +C future extensions. +C +C *** Task Terminated *** +C Reported by the value of IDID=-33 +C +C IDID = -33 -- The code has encountered trouble from which +C it cannot recover. A message is printed +C explaining the trouble and control is returned +C to the calling program. For example, this occurs +C when invalid input is detected. +C +C RTOL, ATOL -- These quantities remain unchanged except when +C IDID = -2. In this case, the error tolerances have been +C increased by the code to values which are estimated to be +C appropriate for continuing the integration. However, the +C reported solution at T was obtained using the input values +C of RTOL and ATOL. +C +C RWORK, IWORK -- Contain information which is usually of no +C interest to the user but necessary for subsequent calls. +C However, you may find use for +C +C RWORK(11)--which contains the step size H to be +C attempted on the next step. +C +C RWORK(12)--if the tolerances have been increased by the +C code (IDID = -2) , they were multiplied by the +C value in RWORK(12). +C +C RWORK(13)--Which contains the current value of the +C independent variable, i.e. the farthest point +C integration has reached. This will be different +C from T only when interpolation has been +C performed (IDID=3). +C +C RWORK(20+I)--Which contains the approximate derivative +C of the solution component Y(I). In DDEABM, it +C is obtained by calling subroutine DF to +C evaluate the differential equation using T and +C Y(*) when IDID=1 or 2, and by interpolation +C when IDID=3. +C +C ********************************************************************** +C * INPUT -- What To Do To Continue The Integration * +C * (calls after the first) * +C ********************************************************************** +C +C This code is organized so that subsequent calls to continue the +C integration involve little (if any) additional effort on your +C part. You must monitor the IDID parameter in order to determine +C what to do next. +C +C Recalling that the principal task of the code is to integrate +C from T to TOUT (the interval mode), usually all you will need +C to do is specify a new TOUT upon reaching the current TOUT. +C +C Do not alter any quantity not specifically permitted below, +C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or +C the differential equation in subroutine DF. Any such alteration +C constitutes a new problem and must be treated as such, i.e. +C you must start afresh. +C +C You cannot change from vector to scalar error control or vice +C versa (INFO(2)) but you can change the size of the entries of +C RTOL, ATOL. Increasing a tolerance makes the equation easier +C to integrate. Decreasing a tolerance will make the equation +C harder to integrate and should generally be avoided. +C +C You can switch from the intermediate-output mode to the +C interval mode (INFO(3)) or vice versa at any time. +C +C If it has been necessary to prevent the integration from going +C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the +C code will not integrate to any TOUT beyond the currently +C specified TSTOP. Once TSTOP has been reached you must change +C the value of TSTOP or set INFO(4)=0. You may change INFO(4) +C or TSTOP at any time but you must supply the value of TSTOP in +C RWORK(1) whenever you set INFO(4)=1. +C +C The parameter INFO(1) is used by the code to indicate the +C beginning of a new problem and to indicate whether integration +C is to be continued. You must input the value INFO(1) = 0 +C when starting a new problem. You must input the value +C INFO(1) = 1 if you wish to continue after an interrupted task. +C Do not set INFO(1) = 0 on a continuation call unless you +C want the code to restart at the current T. +C +C *** Following A Completed Task *** +C If +C IDID = 1, call the code again to continue the integration +C another step in the direction of TOUT. +C +C IDID = 2 or 3, define a new TOUT and call the code again. +C TOUT must be different from T. You cannot change +C the direction of integration without restarting. +C +C *** Following An Interrupted Task *** +C To show the code that you realize the task was +C interrupted and that you want to continue, you +C must take appropriate action and reset INFO(1) = 1 +C If +C IDID = -1, the code has attempted 500 steps. +C If you want to continue, set INFO(1) = 1 and +C call the code again. An additional 500 steps +C will be allowed. +C +C IDID = -2, the error tolerances RTOL, ATOL have been +C increased to values the code estimates appropriate +C for continuing. You may want to change them +C yourself. If you are sure you want to continue +C with relaxed error tolerances, set INFO(1)=1 and +C call the code again. +C +C IDID = -3, a solution component is zero and you set the +C corresponding component of ATOL to zero. If you +C are sure you want to continue, you must first +C alter the error criterion to use positive values +C for those components of ATOL corresponding to zero +C solution components, then set INFO(1)=1 and call +C the code again. +C +C IDID = -4, the problem appears to be stiff. It is very +C inefficient to solve such problems with DDEABM. +C The code DDEBDF in DEPAC handles this task +C efficiently. If you are absolutely sure you want +C to continue with DDEABM, set INFO(1)=1 and call +C the code again. +C +C IDID = -5,-6,-7,..,-32 --- cannot occur with this code +C but used by other members of DEPAC or possible +C future extensions. +C +C *** Following A Terminated Task *** +C If +C IDID = -33, you cannot continue the solution of this +C problem. An attempt to do so will result in your +C run being terminated. +C +C ********************************************************************** +C *Long Description: +C +C ********************************************************************** +C * DEPAC Package Overview * +C ********************************************************************** +C +C .... You have a choice of three differential equation solvers from +C .... DEPAC. The following brief descriptions are meant to aid you in +C .... choosing the most appropriate code for your problem. +C +C .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of +C .... the three choices, both algorithmically and in the use of the +C .... code. DDERKF is primarily designed to solve non-stiff and +C .... mildly stiff differential equations when derivative evaluations +C .... are not expensive. It should generally not be used to get high +C .... accuracy results nor answers at a great many specific points. +C .... Because DDERKF has very low overhead costs, it will usually +C .... result in the least expensive integration when solving +C .... problems requiring a modest amount of accuracy and having +C .... equations that are not costly to evaluate. DDERKF attempts to +C .... discover when it is not suitable for the task posed. +C +C .... DDEABM is a variable order (one through twelve) Adams code. +C .... Its complexity lies somewhere between that of DDERKF and +C .... DDEBDF. DDEABM is primarily designed to solve non-stiff and +C .... mildly stiff differential equations when derivative evaluations +C .... are expensive, high accuracy results are needed or answers at +C .... many specific points are required. DDEABM attempts to discover +C .... when it is not suitable for the task posed. +C +C .... DDEBDF is a variable order (one through five) backward +C .... differentiation formula code. it is the most complicated of +C .... the three choices. DDEBDF is primarily designed to solve stiff +C .... differential equations at crude to moderate tolerances. +C .... If the problem is very stiff at all, DDERKF and DDEABM will be +C .... quite inefficient compared to DDEBDF. However, DDEBDF will be +C .... inefficient compared to DDERKF and DDEABM on non-stiff problems +C .... because it uses much more storage, has a much larger overhead, +C .... and the low order formulas will not give high accuracies +C .... efficiently. +C +C .... The concept of stiffness cannot be described in a few words. +C .... If you do not know the problem to be stiff, try either DDERKF +C .... or DDEABM. Both of these codes will inform you of stiffness +C .... when the cost of solving such problems becomes important. +C +C ********************************************************************* +C +C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user +C oriented package of ODE solvers, Report SAND79-2374, +C Sandia Laboratories, 1979. +C***ROUTINES CALLED DDES, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891006 Cosmetic changes to prologue. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891024 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900510 Convert XERRWV calls to XERMSG calls. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DDEABM +C + INTEGER IALPHA, IBETA, IDELSN, IDID, IFOURU, IG, IHOLD, + 1 INFO, IP, IPAR, IPHI, IPSI, ISIG, ITOLD, ITSTAR, ITWOU, + 2 IV, IW, IWORK, IWT, IYP, IYPOUT, IYY, LIW, LRW, NEQ + DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y + LOGICAL START,PHASE1,NORND,STIFF,INTOUT +C + DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), + 1 RPAR(*),IPAR(*) +C + CHARACTER*8 XERN1 + CHARACTER*16 XERN3 +C + EXTERNAL DF +C +C CHECK FOR AN APPARENT INFINITE LOOP +C +C***FIRST EXECUTABLE STATEMENT DDEABM + IF ( INFO(1) .EQ. 0 ) IWORK(LIW) = 0 + IF (IWORK(LIW) .GE. 5) THEN + IF (T .EQ. RWORK(21 + NEQ)) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DDEABM', + * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // + * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // + * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // + * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // + * 'CODE, PARTICULARLY INFO(1).', 13, 2) + RETURN + ENDIF + ENDIF +C +C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION +C + IDID=0 + IF (LRW .LT. 130+21*NEQ) THEN + WRITE (XERN1, '(I8)') LRW + CALL XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE RWORK ' // + * 'ARRAY MUST BE AT LEAST 130 + 21*NEQ.$$' // + * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) + IDID=-33 + ENDIF +C + IF (LIW .LT. 51) THEN + WRITE (XERN1, '(I8)') LIW + CALL XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE IWORK ' // + * 'ARRAY MUST BE AT LEAST 51.$$YOU HAVE CALLED THE CODE ' // + * 'WITH LIW = ' // XERN1, 2, 1) + IDID=-33 + ENDIF +C +C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY +C + IYPOUT = 21 + ITSTAR = NEQ + 21 + IYP = 1 + ITSTAR + IYY = NEQ + IYP + IWT = NEQ + IYY + IP = NEQ + IWT + IPHI = NEQ + IP + IALPHA = (NEQ*16) + IPHI + IBETA = 12 + IALPHA + IPSI = 12 + IBETA + IV = 12 + IPSI + IW = 12 + IV + ISIG = 12 + IW + IG = 13 + ISIG + IGI = 13 + IG + IXOLD = 11 + IGI + IHOLD = 1 + IXOLD + ITOLD = 1 + IHOLD + IDELSN = 1 + ITOLD + ITWOU = 1 + IDELSN + IFOURU = 1 + ITWOU +C + RWORK(ITSTAR) = T + IF (INFO(1) .EQ. 0) GO TO 50 + START = IWORK(21) .NE. (-1) + PHASE1 = IWORK(22) .NE. (-1) + NORND = IWORK(23) .NE. (-1) + STIFF = IWORK(24) .NE. (-1) + INTOUT = IWORK(25) .NE. (-1) +C + 50 CALL DDES(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(IYPOUT), + 1 RWORK(IYP),RWORK(IYY),RWORK(IWT),RWORK(IP),RWORK(IPHI), + 2 RWORK(IALPHA),RWORK(IBETA),RWORK(IPSI),RWORK(IV), + 3 RWORK(IW),RWORK(ISIG),RWORK(IG),RWORK(IGI),RWORK(11), + 4 RWORK(12),RWORK(13),RWORK(IXOLD),RWORK(IHOLD), + 5 RWORK(ITOLD),RWORK(IDELSN),RWORK(1),RWORK(ITWOU), + 5 RWORK(IFOURU),START,PHASE1,NORND,STIFF,INTOUT,IWORK(26), + 6 IWORK(27),IWORK(28),IWORK(29),IWORK(30),IWORK(31), + 7 IWORK(32),IWORK(33),IWORK(34),IWORK(35),IWORK(45), + 8 RPAR,IPAR) +C + IWORK(21) = -1 + IF (START) IWORK(21) = 1 + IWORK(22) = -1 + IF (PHASE1) IWORK(22) = 1 + IWORK(23) = -1 + IF (NORND) IWORK(23) = 1 + IWORK(24) = -1 + IF (STIFF) IWORK(24) = 1 + IWORK(25) = -1 + IF (INTOUT) IWORK(25) = 1 +C + IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 + IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 +C + RETURN + END diff --git a/SLATEC/src/dderkf.f b/SLATEC/src/dderkf.f new file mode 100644 index 0000000..9de5a10 --- /dev/null +++ b/SLATEC/src/dderkf.f @@ -0,0 +1,698 @@ +*DECK DDERKF + SUBROUTINE DDERKF (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, + + RWORK, LRW, IWORK, LIW, RPAR, IPAR) +C***BEGIN PROLOGUE DDERKF +C***PURPOSE Solve an initial value problem in ordinary differential +C equations using a Runge-Kutta-Fehlberg scheme. +C***LIBRARY SLATEC (DEPAC) +C***CATEGORY I1A1A +C***TYPE DOUBLE PRECISION (DERKF-S, DDERKF-D) +C***KEYWORDS DEPAC, INITIAL VALUE PROBLEMS, ODE, +C ORDINARY DIFFERENTIAL EQUATIONS, RKF, +C RUNGE-KUTTA-FEHLBERG METHODS +C***AUTHOR Watts, H. A., (SNLA) +C Shampine, L. F., (SNLA) +C***DESCRIPTION +C +C This is the Runge-Kutta code in the package of differential equation +C solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. +C Design of the package was by L. F. Shampine and H. A. Watts. +C It is documented in +C SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE +C Solvers. +C DDERKF is a driver for a modification of the code RKF45 written by +C H. A. Watts and L. F. Shampine +C Sandia Laboratories +C Albuquerque, New Mexico 87185 +C +C ********************************************************************** +C ** DDEPAC PACKAGE OVERVIEW ** +C ********************************************************************** +C +C You have a choice of three differential equation solvers from +C DDEPAC. The following brief descriptions are meant to aid you +C in choosing the most appropriate code for your problem. +C +C DDERKF is a fifth order Runge-Kutta code. It is the simplest of +C the three choices, both algorithmically and in the use of the +C code. DDERKF is primarily designed to solve non-stiff and mild- +C ly stiff differential equations when derivative evaluations are +C not expensive. It should generally not be used to get high +C accuracy results nor answers at a great many specific points. +C Because DDERKF has very low overhead costs, it will usually +C result in the least expensive integration when solving +C problems requiring a modest amount of accuracy and having +C equations that are not costly to evaluate. DDERKF attempts to +C discover when it is not suitable for the task posed. +C +C DDEABM is a variable order (one through twelve) Adams code. Its +C complexity lies somewhere between that of DDERKF and DDEBDF. +C DDEABM is primarily designed to solve non-stiff and mildly +C stiff differential equations when derivative evaluations are +C expensive, high accuracy results are needed or answers at +C many specific points are required. DDEABM attempts to discover +C when it is not suitable for the task posed. +C +C DDEBDF is a variable order (one through five) backward +C differentiation formula code. It is the most complicated of +C the three choices. DDEBDF is primarily designed to solve stiff +C differential equations at crude to moderate tolerances. +C If the problem is very stiff at all, DDERKF and DDEABM will be +C quite inefficient compared to DDEBDF. However, DDEBDF will be +C inefficient compared to DDERKF and DDEABM on non-stiff problems +C because it uses much more storage, has a much larger overhead, +C and the low order formulas will not give high accuracies +C efficiently. +C +C The concept of stiffness cannot be described in a few words. +C If you do not know the problem to be stiff, try either DDERKF +C or DDEABM. Both of these codes will inform you of stiffness +C when the cost of solving such problems becomes important. +C +C ********************************************************************** +C ** ABSTRACT ** +C ********************************************************************** +C +C Subroutine DDERKF uses a Runge-Kutta-Fehlberg (4,5) method to +C integrate a system of NEQ first order ordinary differential +C equations of the form +C DU/DX = DF(X,U) +C when the vector Y(*) of initial values for U(*) at X=T is given. +C The subroutine integrates from T to TOUT. It is easy to continue the +C integration to get results at additional TOUT. This is the interval +C mode of operation. It is also easy for the routine to return with +C the solution at each intermediate step on the way to TOUT. This is +C the intermediate-output mode of operation. +C +C DDERKF uses subprograms DRKFS, DFEHL, DHSTRT, DHVNRM, D1MACH, and +C the error handling routine XERMSG. The only machine dependent +C parameters to be assigned appear in D1MACH. +C +C ********************************************************************** +C ** DESCRIPTION OF THE ARGUMENTS TO DDERKF (AN OVERVIEW) ** +C ********************************************************************** +C +C The Parameters are: +C +C DF -- This is the name of a subroutine which you provide to +C define the differential equations. +C +C NEQ -- This is the number of (first order) differential +C equations to be integrated. +C +C T -- This is a DOUBLE PRECISION value of the independent +C variable. +C +C Y(*) -- This DOUBLE PRECISION array contains the solution +C components at T. +C +C TOUT -- This is a DOUBLE PRECISION point at which a solution is +C desired. +C +C INFO(*) -- The basic task of the code is to integrate the +C differential equations from T to TOUT and return an +C answer at TOUT. INFO(*) is an INTEGER array which is used +C to communicate exactly how you want this task to be +C carried out. +C +C RTOL, ATOL -- These DOUBLE PRECISION quantities represent +C relative and absolute error tolerances which you provide +C to indicate how accurately you wish the solution to be +C computed. You may choose them to be both scalars or else +C both vectors. +C +C IDID -- This scalar quantity is an indicator reporting what +C the code did. You must monitor this INTEGER variable to +C decide what action to take next. +C +C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of +C length LRW which provides the code with needed storage +C space. +C +C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW +C which provides the code with needed storage space and an +C across call flag. +C +C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and the DF subroutine. +C +C Quantities which are used as input items are +C NEQ, T, Y(*), TOUT, INFO(*), +C RTOL, ATOL, LRW and LIW. +C +C Quantities which may be altered by the code are +C T, Y(*), INFO(1), RTOL, ATOL, +C IDID, RWORK(*) and IWORK(*). +C +C ********************************************************************** +C ** INPUT -- What to do On The First Call To DDERKF ** +C ********************************************************************** +C +C The first call of the code is defined to be the start of each new +C problem. Read through the descriptions of all the following items, +C provide sufficient storage space for designated arrays, set +C appropriate variables for the initialization of the problem, and +C give information about how you want the problem to be solved. +C +C +C DF -- Provide a subroutine of the form +C DF(X,U,UPRIME,RPAR,IPAR) +C to define the system of first order differential equations +C which is to be solved. For the given values of X and the +C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must +C evaluate the NEQ components of the system of differential +C equations DU/DX=DF(X,U) and store the derivatives in the +C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for +C equations I=1,...,NEQ. +C +C Subroutine DF must not alter X or U(*). You must declare +C the name DF in an external statement in your program that +C calls DDERKF. You must dimension U and UPRIME in DF. +C +C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and subroutine DF. They are not used or +C altered by DDERKF. If you do not need RPAR or IPAR, +C ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension them in +C your calling program and in DF as arrays of appropriate +C length. +C +C NEQ -- Set it to the number of differential equations. +C (NEQ .GE. 1) +C +C T -- Set it to the initial point of the integration. +C You must use a program variable for T because the code +C changes its value. +C +C Y(*) -- Set this vector to the initial values of the NEQ solution +C components at the initial point. You must dimension Y at +C least NEQ in your calling program. +C +C TOUT -- Set it to the first point at which a solution +C is desired. You can take TOUT = T, in which case the code +C will evaluate the derivative of the solution at T and +C return. Integration either forward in T (TOUT .GT. T) or +C backward in T (TOUT .LT. T) is permitted. +C +C The code advances the solution from T to TOUT using +C step sizes which are automatically selected so as to +C achieve the desired accuracy. If you wish, the code will +C return with the solution and its derivative following +C each intermediate step (intermediate-output mode) so that +C you can monitor them, but you still must provide TOUT in +C accord with the basic aim of the code. +C +C The first step taken by the code is a critical one +C because it must reflect how fast the solution changes near +C the initial point. The code automatically selects an +C initial step size which is practically always suitable for +C the problem. By using the fact that the code will not +C step past TOUT in the first step, you could, if necessary, +C restrict the length of the initial step size. +C +C For some problems it may not be permissible to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP. Since DDERKF will never step past a TOUT point, +C you need only make sure that no TOUT lies beyond TSTOP. +C +C INFO(*) -- Use the INFO array to give the code more details about +C how you want your problem solved. This array should be +C dimensioned of length 15 to accommodate other members of +C DEPAC or possible future extensions, though DDERKF uses +C only the first three entries. You must respond to all of +C the following items which are arranged as questions. The +C simplest use of the code corresponds to answering all +C questions as YES ,i.e. setting all entries of INFO to 0. +C +C INFO(1) -- This parameter enables the code to initialize +C itself. You must set it to indicate the start of every +C new problem. +C +C **** Is this the first call for this problem ... +C YES -- Set INFO(1) = 0 +C NO -- Not applicable here. +C See below for continuation calls. **** +C +C INFO(2) -- How much accuracy you want of your solution +C is specified by the error tolerances RTOL and ATOL. +C The simplest use is to take them both to be scalars. +C To obtain more flexibility, they can both be vectors. +C The code must be told your choice. +C +C **** Are both error tolerances RTOL, ATOL scalars ... +C YES -- Set INFO(2) = 0 +C and input scalars for both RTOL and ATOL +C NO -- Set INFO(2) = 1 +C and input arrays for both RTOL and ATOL **** +C +C INFO(3) -- The code integrates from T in the direction +C of TOUT by steps. If you wish, it will return the +C computed solution and derivative at the next +C intermediate step (the intermediate-output mode). +C This is a good way to proceed if you want to see the +C behavior of the solution. If you must have solutions at +C a great many specific TOUT points, this code is +C INEFFICIENT. The code DDEABM in DEPAC handles this task +C more efficiently. +C +C **** Do you want the solution only at +C TOUT (and not at the next intermediate step) ... +C YES -- Set INFO(3) = 0 +C NO -- Set INFO(3) = 1 **** +C +C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) +C error tolerances to tell the code how accurately you want +C the solution to be computed. They must be defined as +C program variables because the code may change them. You +C have two choices -- +C Both RTOL and ATOL are scalars. (INFO(2)=0) +C Both RTOL and ATOL are vectors. (INFO(2)=1) +C In either case all components must be non-negative. +C +C The tolerances are used by the code in a local error test +C at each step which requires roughly that +C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL +C for each vector component. +C (More specifically, a maximum norm is used to measure +C the size of vectors, and the error test uses the average +C of the magnitude of the solution at the beginning and end +C of the step.) +C +C The true (global) error is the difference between the true +C solution of the initial value problem and the computed +C approximation. Practically all present day codes, +C including this one, control the local error at each step +C and do not even attempt to control the global error +C directly. Roughly speaking, they produce a solution Y(T) +C which satisfies the differential equations with a +C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , +C and, almost always, R(T) is bounded by the error +C tolerances. Usually, but not always, the true accuracy of +C the computed Y is comparable to the error tolerances. This +C code will usually, but not always, deliver a more accurate +C solution if you reduce the tolerances and integrate again. +C By comparing two such solutions you can get a fairly +C reliable idea of the true error in the solution at the +C bigger tolerances. +C +C Setting ATOL=0. results in a pure relative error test on +C that component. Setting RTOL=0. yields a pure absolute +C error test on that component. A mixed test with non-zero +C RTOL and ATOL corresponds roughly to a relative error +C test when the solution component is much bigger than ATOL +C and to an absolute error test when the solution component +C is smaller than the threshold ATOL. +C +C Proper selection of the absolute error control parameters +C ATOL requires you to have some idea of the scale of the +C solution components. To acquire this information may mean +C that you will have to solve the problem more than once. In +C the absence of scale information, you should ask for some +C relative accuracy in all the components (by setting RTOL +C values non-zero) and perhaps impose extremely small +C absolute error tolerances to protect against the danger of +C a solution component becoming zero. +C +C The code will not attempt to compute a solution at an +C accuracy unreasonable for the machine being used. It will +C advise you if you ask for too much accuracy and inform +C you as to the maximum accuracy it believes possible. +C If you want relative accuracies smaller than about +C 10**(-8), you should not ordinarily use DDERKF. The code +C DDEABM in DEPAC obtains stringent accuracies more +C efficiently. +C +C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length +C LRW in your calling program. +C +C LRW -- Set it to the declared length of the RWORK array. +C You must have LRW .GE. 33+7*NEQ +C +C IWORK(*) -- Dimension this INTEGER work array of length LIW in +C your calling program. +C +C LIW -- Set it to the declared length of the IWORK array. +C You must have LIW .GE. 34 +C +C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and +C INTEGER type, respectively. You can use them for +C communication between your program that calls DDERKF and +C the DF subroutine. They are not used or altered by +C DDERKF. If you do not need RPAR or IPAR, ignore these +C parameters by treating them as dummy arguments. If you do +C choose to use them, dimension them in your calling program +C and in DF as arrays of appropriate length. +C +C ********************************************************************** +C ** OUTPUT -- After any return from DDERKF ** +C ********************************************************************** +C +C The principal aim of the code is to return a computed solution at +C TOUT, although it is also possible to obtain intermediate results +C along the way. To find out whether the code achieved its goal +C or if the integration process was interrupted before the task was +C completed, you must check the IDID parameter. +C +C +C T -- The solution was successfully advanced to the +C output value of T. +C +C Y(*) -- Contains the computed solution approximation at T. +C You may also be interested in the approximate derivative +C of the solution at T. It is contained in +C RWORK(21),...,RWORK(20+NEQ). +C +C IDID -- Reports what the code did +C +C *** Task Completed *** +C Reported by positive values of IDID +C +C IDID = 1 -- A step was successfully taken in the +C intermediate-output mode. The code has not +C yet reached TOUT. +C +C IDID = 2 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping exactly to TOUT. +C +C *** Task Interrupted *** +C Reported by negative values of IDID +C +C IDID = -1 -- A large amount of work has been expended. +C (500 steps attempted) +C +C IDID = -2 -- The error tolerances are too stringent. +C +C IDID = -3 -- The local error test cannot be satisfied +C because you specified a zero component in ATOL +C and the corresponding computed solution +C component is zero. Thus, a pure relative error +C test is impossible for this component. +C +C IDID = -4 -- The problem appears to be stiff. +C +C IDID = -5 -- DDERKF is being used very inefficiently +C because the natural step size is being +C restricted by too frequent output. +C +C IDID = -6,-7,..,-32 -- Not applicable for this code but +C used by other members of DEPAC or possible +C future extensions. +C +C *** Task Terminated *** +C Reported by the value of IDID=-33 +C +C IDID = -33 -- The code has encountered trouble from which +C it cannot recover. A message is printed +C explaining the trouble and control is returned +C to the calling program. For example, this +C occurs when invalid input is detected. +C +C RTOL, ATOL -- These quantities remain unchanged except when +C IDID = -2. In this case, the error tolerances have been +C increased by the code to values which are estimated to be +C appropriate for continuing the integration. However, the +C reported solution at T was obtained using the input values +C of RTOL and ATOL. +C +C RWORK, IWORK -- Contain information which is usually of no +C interest to the user but necessary for subsequent calls. +C However, you may find use for +C +C RWORK(11)--which contains the step size H to be +C attempted on the next step. +C +C RWORK(12)--If the tolerances have been increased by the +C code (IDID = -2) , they were multiplied by the +C value in RWORK(12). +C +C RWORK(20+I)--which contains the approximate derivative +C of the solution component Y(I). In DDERKF, it +C is always obtained by calling subroutine DF to +C evaluate the differential equation using T and +C Y(*). +C +C ********************************************************************** +C ** INPUT -- What To Do To Continue The Integration ** +C ** (calls after the first) ** +C ********************************************************************** +C +C This code is organized so that subsequent calls to continue the +C integration involve little (if any) additional effort on your +C part. You must monitor the IDID parameter to determine +C what to do next. +C +C Recalling that the principal task of the code is to integrate +C from T to TOUT (the interval mode), usually all you will need +C to do is specify a new TOUT upon reaching the current TOUT. +C +C Do not alter any quantity not specifically permitted below, +C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or +C the differential equation in subroutine DF. Any such alteration +C constitutes a new problem and must be treated as such, i.e. +C you must start afresh. +C +C You cannot change from vector to scalar error control or vice +C versa (INFO(2)) but you can change the size of the entries of +C RTOL, ATOL. Increasing a tolerance makes the equation easier +C to integrate. Decreasing a tolerance will make the equation +C harder to integrate and should generally be avoided. +C +C You can switch from the intermediate-output mode to the +C interval mode (INFO(3)) or vice versa at any time. +C +C The parameter INFO(1) is used by the code to indicate the +C beginning of a new problem and to indicate whether integration +C is to be continued. You must input the value INFO(1) = 0 +C when starting a new problem. You must input the value +C INFO(1) = 1 if you wish to continue after an interrupted task. +C Do not set INFO(1) = 0 on a continuation call unless you +C want the code to restart at the current T. +C +C *** Following a Completed Task *** +C If +C IDID = 1, call the code again to continue the integration +C another step in the direction of TOUT. +C +C IDID = 2, define a new TOUT and call the code again. +C TOUT must be different from T. You cannot change +C the direction of integration without restarting. +C +C *** Following an Interrupted Task *** +C To show the code that you realize the task was +C interrupted and that you want to continue, you +C must take appropriate action and reset INFO(1) = 1 +C If +C IDID = -1, the code has attempted 500 steps. +C If you want to continue, set INFO(1) = 1 and +C call the code again. An additional 500 steps +C will be allowed. +C +C IDID = -2, the error tolerances RTOL, ATOL have been +C increased to values the code estimates appropriate +C for continuing. You may want to change them +C yourself. If you are sure you want to continue +C with relaxed error tolerances, set INFO(1)=1 and +C call the code again. +C +C IDID = -3, a solution component is zero and you set the +C corresponding component of ATOL to zero. If you +C are sure you want to continue, you must first +C alter the error criterion to use positive values +C for those components of ATOL corresponding to zero +C solution components, then set INFO(1)=1 and call +C the code again. +C +C IDID = -4, the problem appears to be stiff. It is very +C inefficient to solve such problems with DDERKF. +C The code DDEBDF in DEPAC handles this task +C efficiently. If you are absolutely sure you want +C to continue with DDERKF, set INFO(1)=1 and call +C the code again. +C +C IDID = -5, you are using DDERKF very inefficiently by +C choosing output points TOUT so close together that +C the step size is repeatedly forced to be rather +C smaller than necessary. If you are willing to +C accept solutions at the steps chosen by the code, +C a good way to proceed is to use the intermediate +C output mode (setting INFO(3)=1). If you must have +C solutions at so many specific TOUT points, the +C code DDEABM in DEPAC handles this task +C efficiently. If you want to continue with DDERKF, +C set INFO(1)=1 and call the code again. +C +C IDID = -6,-7,..,-32 --- cannot occur with this code but +C used by other members of DEPAC or possible future +C extensions. +C +C *** Following a Terminated Task *** +C If +C IDID = -33, you cannot continue the solution of this +C problem. An attempt to do so will result in your +C run being terminated. +C +C ********************************************************************** +C *Long Description: +C +C ********************************************************************** +C ** DEPAC Package Overview ** +C ********************************************************************** +C +C .... You have a choice of three differential equation solvers from +C .... DEPAC. The following brief descriptions are meant to aid you in +C .... choosing the most appropriate code for your problem. +C +C .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of +C .... the three choices, both algorithmically and in the use of the +C .... code. DDERKF is primarily designed to solve non-stiff and +C .... mildly stiff differential equations when derivative evaluations +C .... are not expensive. It should generally not be used to get high +C .... accuracy results nor answers at a great many specific points. +C .... Because DDERKF has very low overhead costs, it will usually +C .... result in the least expensive integration when solving +C .... problems requiring a modest amount of accuracy and having +C .... equations that are not costly to evaluate. DDERKF attempts to +C .... discover when it is not suitable for the task posed. +C +C .... DDEABM is a variable order (one through twelve) Adams code. +C .... Its complexity lies somewhere between that of DDERKF and +C .... DDEBDF. DDEABM is primarily designed to solve non-stiff and +C .... mildly stiff differential equations when derivative evaluations +C .... are expensive, high accuracy results are needed or answers at +C .... many specific points are required. DDEABM attempts to discover +C .... when it is not suitable for the task posed. +C +C .... DDEBDF is a variable order (one through five) backward +C .... differentiation formula code. it is the most complicated of +C .... the three choices. DDEBDF is primarily designed to solve stiff +C .... differential equations at crude to moderate tolerances. +C .... If the problem is very stiff at all, DDERKF and DDEABM will be +C .... quite inefficient compared to DDEBDF. However, DDEBDF will be +C .... inefficient compared to DDERKF and DDEABM on non-stiff problems +C .... because it uses much more storage, has a much larger overhead, +C .... and the low order formulas will not give high accuracies +C .... efficiently. +C +C .... The concept of stiffness cannot be described in a few words. +C .... If you do not know the problem to be stiff, try either DDERKF +C .... or DDEABM. Both of these codes will inform you of stiffness +C .... when the cost of solving such problems becomes important. +C +C ********************************************************************* +C +C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user +C oriented package of ODE solvers, Report SAND79-2374, +C Sandia Laboratories, 1979. +C L. F. Shampine and H. A. Watts, Practical solution of +C ordinary differential equations by Runge-Kutta +C methods, Report SAND76-0585, Sandia Laboratories, +C 1976. +C***ROUTINES CALLED DRKFS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891024 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900510 Convert XERRWV calls to XERMSG calls, make Prologue comments +C consistent with DERKF. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DDERKF +C + INTEGER IDID, INFO, IPAR, IWORK, KDI, KF1, KF2, KF3, KF4, KF5, + 1 KH, KRER, KTF, KTO, KTSTAR, KU, KYP, KYS, LIW, LRW, NEQ + DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y + LOGICAL STIFF,NONSTF +C + DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), + 1 RPAR(*),IPAR(*) + CHARACTER*8 XERN1 + CHARACTER*16 XERN3 +C + EXTERNAL DF +C +C CHECK FOR AN APPARENT INFINITE LOOP +C +C***FIRST EXECUTABLE STATEMENT DDERKF + IF (INFO(1) .EQ. 0) IWORK(LIW) = 0 + IF (IWORK(LIW) .GE. 5) THEN + IF (T .EQ. RWORK(21+NEQ)) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DDERKF', + * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // + * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // + * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // + * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // + * 'CODE, PARTICULARLY INFO(1).', 13, 2) + RETURN + ENDIF + ENDIF +C +C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION +C + IDID = 0 + IF (LRW .LT. 30 + 7*NEQ) THEN + WRITE (XERN1, '(I8)') LRW + CALL XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF RWORK ARRAY ' // + * 'MUST BE AT LEAST 30 + 7*NEQ. YOU HAVE CALLED THE ' // + * 'CODE WITH LRW = ' // XERN1, 1, 1) + IDID = -33 + ENDIF +C + IF (LIW .LT. 34) THEN + WRITE (XERN1, '(I8)') LIW + CALL XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF IWORK ARRAY ' // + * 'MUST BE AT LEAST 34. YOU HAVE CALLED THE CODE WITH ' // + * 'LIW = ' // XERN1, 2, 1) + IDID = -33 + ENDIF +C +C COMPUTE INDICES FOR THE SPLITTING OF THE RWORK ARRAY +C + KH = 11 + KTF = 12 + KYP = 21 + KTSTAR = KYP + NEQ + KF1 = KTSTAR + 1 + KF2 = KF1 + NEQ + KF3 = KF2 + NEQ + KF4 = KF3 + NEQ + KF5 = KF4 + NEQ + KYS = KF5 + NEQ + KTO = KYS + NEQ + KDI = KTO + 1 + KU = KDI + 1 + KRER = KU + 1 +C +C ********************************************************************** +C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG +C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE +C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, +C S/HE MUST USE DRKFS DIRECTLY. +C ********************************************************************** +C + RWORK(KTSTAR) = T + IF (INFO(1) .NE. 0) THEN + STIFF = (IWORK(25) .EQ. 0) + NONSTF = (IWORK(26) .EQ. 0) + ENDIF +C + CALL DRKFS(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(KH), + 1 RWORK(KTF),RWORK(KYP),RWORK(KF1),RWORK(KF2),RWORK(KF3), + 2 RWORK(KF4),RWORK(KF5),RWORK(KYS),RWORK(KTO),RWORK(KDI), + 3 RWORK(KU),RWORK(KRER),IWORK(21),IWORK(22),IWORK(23), + 4 IWORK(24),STIFF,NONSTF,IWORK(27),IWORK(28),RPAR,IPAR) +C + IWORK(25) = 1 + IF (STIFF) IWORK(25) = 0 + IWORK(26) = 1 + IF (NONSTF) IWORK(26) = 0 +C + IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 + IF (T .NE. RWORK(KTSTAR)) IWORK(LIW) = 0 +C + RETURN + END diff --git a/SLATEC/src/ddes.f b/SLATEC/src/ddes.f new file mode 100644 index 0000000..b883381 --- /dev/null +++ b/SLATEC/src/ddes.f @@ -0,0 +1,430 @@ +*DECK DDES + SUBROUTINE DDES (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, + + YPOUT, YP, YY, WT, P, PHI, ALPHA, BETA, PSI, V, W, SIG, G, GI, + + H, EPS, X, XOLD, HOLD, TOLD, DELSGN, TSTOP, TWOU, FOURU, START, + + PHASE1, NORND, STIFF, INTOUT, NS, KORD, KOLD, INIT, KSTEPS, + + KLE4, IQUIT, KPREV, IVC, IV, KGI, RPAR, IPAR) +C***BEGIN PROLOGUE DDES +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEABM +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (DES-S, DDES-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DDEABM merely allocates storage for DDES to relieve the user of the +C inconvenience of a long call list. Consequently DDES is used as +C described in the comments for DDEABM . +C +C***SEE ALSO DDEABM +C***ROUTINES CALLED D1MACH, DINTP, DSTEPS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTOs to +C IF-THEN-ELSE. (RWC) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DDES +C + INTEGER IDID, INFO, INIT, IPAR, IQUIT, IV, IVC, K, KGI, KLE4, + 1 KOLD, KORD, KPREV, KSTEPS, L, LTOL, MAXNUM, NATOLP, NEQ, + 2 NRTOLP, NS + DOUBLE PRECISION A, ABSDEL, ALPHA, ATOL, BETA, D1MACH, + 1 DEL, DELSGN, DT, EPS, FOURU, G, GI, H, + 2 HA, HOLD, P, PHI, PSI, RPAR, RTOL, SIG, T, TOLD, TOUT, + 3 TSTOP, TWOU, U, V, W, WT, X, XOLD, Y, YP, YPOUT, YY + LOGICAL STIFF,CRASH,START,PHASE1,NORND,INTOUT +C + DIMENSION Y(*),YY(*),WT(*),PHI(NEQ,16),P(*),YP(*), + 1 YPOUT(*),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13), + 2 GI(11),IV(10),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) + CHARACTER*8 XERN1 + CHARACTER*16 XERN3, XERN4 +C + EXTERNAL DF +C +C....................................................................... +C +C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE +C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER +C IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE +C WORK. +C + SAVE MAXNUM + DATA MAXNUM/500/ +C +C....................................................................... +C +C***FIRST EXECUTABLE STATEMENT DDES + IF (INFO(1) .EQ. 0) THEN +C +C ON THE FIRST CALL , PERFORM INITIALIZATION -- +C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE +C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE +C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. +C + U=D1MACH(4) +C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS + TWOU=2.D0*U + FOURU=4.D0*U +C -- SET TERMINATION FLAG + IQUIT=0 +C -- SET INITIALIZATION INDICATOR + INIT=0 +C -- SET COUNTER FOR ATTEMPTED STEPS + KSTEPS=0 +C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT + INTOUT= .FALSE. +C -- SET INDICATOR FOR STIFFNESS DETECTION + STIFF= .FALSE. +C -- SET STEP COUNTER FOR STIFFNESS DETECTION + KLE4=0 +C -- SET INDICATORS FOR STEPS CODE + START= .TRUE. + PHASE1= .TRUE. + NORND= .TRUE. +C -- RESET INFO(1) FOR SUBSEQUENT CALLS + INFO(1)=1 + ENDIF +C +C....................................................................... +C +C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY +C + IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(1) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(1) MUST BE ' // + * 'SET TO 0 FOR THE START OF A NEW PROBLEM, AND MUST BE ' // + * 'SET TO 1 FOLLOWING AN INTERRUPTED TASK. YOU ARE ' // + * 'ATTEMPTING TO CONTINUE THE INTEGRATION ILLEGALLY BY ' // + * 'CALLING THE CODE WITH INFO(1) = ' // XERN1, 3, 1) + IDID=-33 + ENDIF +C + IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(2) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(2) MUST BE ' // + * '0 OR 1 INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // + * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // + * XERN1, 4, 1) + IDID=-33 + ENDIF +C + IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(3) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(3) MUST BE ' // + * '0 OR 1 INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT ' // + * 'MODE OF INTEGRATION, RESPECTIVELY. YOU HAVE CALLED ' // + * 'THE CODE WITH INFO(3) = ' // XERN1, 5, 1) + IDID=-33 + ENDIF +C + IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(4) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(4) MUST BE ' // + * '0 OR 1 INDICATING WHETHER OR NOT THE INTEGRATION ' // + * 'INTERVAL IS TO BE RESTRICTED BY A POINT TSTOP. YOU ' // + * 'HAVE CALLED THE CODE WITH INFO(4) = ' // XERN1, 14, 1) + IDID=-33 + ENDIF +C + IF (NEQ .LT. 1) THEN + WRITE (XERN1, '(I8)') NEQ + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE NUMBER OF ' // + * 'EQUATIONS NEQ MUST BE A POSITIVE INTEGER. YOU HAVE ' // + * 'CALLED THE CODE WITH NEQ = ' // XERN1, 6, 1) + IDID=-33 + ENDIF +C + NRTOLP = 0 + NATOLP = 0 + DO 90 K=1,NEQ + IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') RTOL(K) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE RELATIVE ' // + * 'ERROR TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU ' // + * 'HAVE CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // + * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // + * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) + IDID = -33 + NRTOLP = 1 + ENDIF +C + IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') ATOL(K) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE ABSOLUTE ' // + * 'ERROR TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU ' // + * 'HAVE CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // + * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // + * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) + IDID = -33 + NATOLP = 1 + ENDIF +C + IF (INFO(2) .EQ. 0) GO TO 100 + IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 100 + 90 CONTINUE +C + 100 IF (INFO(4) .EQ. 1) THEN + IF (SIGN(1.D0,TOUT-T) .NE. SIGN(1.D0,TSTOP-T) + 1 .OR. ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN + WRITE (XERN3, '(1PE15.6)') TOUT + WRITE (XERN4, '(1PE15.6)') TSTOP + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // + * 'CALLED THE CODE WITH TOUT = ' // XERN3 // ' BUT ' // + * 'YOU HAVE ALSO TOLD THE CODE (INFO(4) = 1) NOT TO ' // + * 'INTEGRATE PAST THE POINT TSTOP = ' // XERN4 // + * ' THESE INSTRUCTIONS CONFLICT.', 14, 1) + IDID=-33 + ENDIF + ENDIF +C +C CHECK SOME CONTINUATION POSSIBILITIES +C + IF (INIT .NE. 0) THEN + IF (T .EQ. TOUT) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // + * 'CALLED THE CODE WITH T = TOUT = ' // XERN3 // + * '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 9, 1) + IDID=-33 + ENDIF +C + IF (T .NE. TOLD) THEN + WRITE (XERN3, '(1PE15.6)') TOLD + WRITE (XERN4, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // + * 'CHANGED THE VALUE OF T FROM ' // XERN3 // ' TO ' // + * XERN4 //' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', + * 10, 1) + IDID=-33 + ENDIF +C + IF (INIT .NE. 1) THEN + IF (DELSGN*(TOUT-T) .LT. 0.D0) THEN + WRITE (XERN3, '(1PE15.6)') TOUT + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, BY ' // + * 'CALLING THE CODE WITH TOUT = ' // XERN3 // + * ' YOU ARE ATTEMPTING TO CHANGE THE DIRECTION OF ' // + * 'INTEGRATION.$$THIS IS NOT ALLOWED WITHOUT ' // + * 'RESTARTING.', 11, 1) + IDID=-33 + ENDIF + ENDIF + ENDIF +C +C INVALID INPUT DETECTED +C + IF (IDID .EQ. (-33)) THEN + IF (IQUIT .NE. (-33)) THEN + IQUIT = -33 + INFO(1) = -1 + ELSE + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INVALID ' // + * 'INPUT WAS DETECTED ON SUCCESSIVE ENTRIES. IT IS ' // + * 'IMPOSSIBLE TO PROCEED BECAUSE YOU HAVE NOT ' // + * 'CORRECTED THE PROBLEM, SO EXECUTION IS BEING ' // + * 'TERMINATED.', 12, 2) + ENDIF + RETURN + ENDIF +C +C....................................................................... +C +C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS +C ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, +C THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE +C FOURU WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE +C + DO 180 K=1,NEQ + IF (RTOL(K)+ATOL(K) .GT. 0.D0) GO TO 170 + RTOL(K)=FOURU + IDID=-2 + 170 IF (INFO(2) .EQ. 0) GO TO 190 + 180 CONTINUE +C + 190 IF (IDID .NE. (-2)) GO TO 200 +C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A +C SMALL POSITIVE VALUE + INFO(1)=-1 + RETURN +C +C BRANCH ON STATUS OF INITIALIZATION INDICATOR +C INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE +C AND DIRECTION NOT YET SET +C INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET +C INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED +C + 200 IF (INIT .EQ. 0) GO TO 210 + IF (INIT .EQ. 1) GO TO 220 + GO TO 240 +C +C....................................................................... +C +C MORE INITIALIZATION -- +C -- EVALUATE INITIAL DERIVATIVES +C + 210 INIT=1 + A=T + CALL DF(A,Y,YP,RPAR,IPAR) + IF (T .NE. TOUT) GO TO 220 + IDID=2 + DO 215 L = 1,NEQ + 215 YPOUT(L) = YP(L) + TOLD=T + RETURN +C +C -- SET INDEPENDENT AND DEPENDENT VARIABLES +C X AND YY(*) FOR STEPS +C -- SET SIGN OF INTEGRATION DIRECTION +C -- INITIALIZE THE STEP SIZE +C + 220 INIT = 2 + X = T + DO 230 L = 1,NEQ + 230 YY(L) = Y(L) + DELSGN = SIGN(1.0D0,TOUT-T) + H = SIGN(MAX(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X) +C +C....................................................................... +C +C ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL +C OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT +C + 240 DEL = TOUT - T + ABSDEL = ABS(DEL) +C +C....................................................................... +C +C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN +C + 250 IF(ABS(X-T) .LT. ABSDEL) GO TO 260 + CALL DINTP(X,YY,TOUT,Y,YPOUT,NEQ,KOLD,PHI,IVC,IV,KGI,GI, + 1 ALPHA,G,W,XOLD,P) + IDID = 3 + IF (X .NE. TOUT) GO TO 255 + IDID = 2 + INTOUT = .FALSE. + 255 T = TOUT + TOLD = T + RETURN +C +C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, +C EXTRAPOLATE AND RETURN +C + 260 IF (INFO(4) .NE. 1) GO TO 280 + IF (ABS(TSTOP-X) .GE. FOURU*ABS(X)) GO TO 280 + DT = TOUT - X + DO 270 L = 1,NEQ + 270 Y(L) = YY(L) + DT*YP(L) + CALL DF(TOUT,Y,YPOUT,RPAR,IPAR) + IDID = 3 + T = TOUT + TOLD = T + RETURN +C + 280 IF (INFO(3) .EQ. 0 .OR. .NOT.INTOUT) GO TO 300 +C +C INTERMEDIATE-OUTPUT MODE +C + IDID = 1 + DO 290 L = 1,NEQ + Y(L)=YY(L) + 290 YPOUT(L) = YP(L) + T = X + TOLD = T + INTOUT = .FALSE. + RETURN +C +C....................................................................... +C +C MONITOR NUMBER OF STEPS ATTEMPTED +C + 300 IF (KSTEPS .LE. MAXNUM) GO TO 330 +C +C A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED + IDID=-1 + KSTEPS=0 + IF (.NOT. STIFF) GO TO 310 +C +C PROBLEM APPEARS TO BE STIFF + IDID=-4 + STIFF= .FALSE. + KLE4=0 +C + 310 DO 320 L = 1,NEQ + Y(L) = YY(L) + 320 YPOUT(L) = YP(L) + T = X + TOLD = T + INFO(1) = -1 + INTOUT = .FALSE. + RETURN +C +C....................................................................... +C +C LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP +C + 330 HA = ABS(H) + IF (INFO(4) .NE. 1) GO TO 340 + HA = MIN(HA,ABS(TSTOP-X)) + 340 H = SIGN(HA,H) + EPS = 1.0D0 + LTOL = 1 + DO 350 L = 1,NEQ + IF (INFO(2) .EQ. 1) LTOL = L + WT(L) = RTOL(LTOL)*ABS(YY(L)) + ATOL(LTOL) + IF (WT(L) .LE. 0.0D0) GO TO 360 + 350 CONTINUE + GO TO 380 +C +C RELATIVE ERROR CRITERION INAPPROPRIATE + 360 IDID = -3 + DO 370 L = 1,NEQ + Y(L) = YY(L) + 370 YPOUT(L) = YP(L) + T = X + TOLD = T + INFO(1) = -1 + INTOUT = .FALSE. + RETURN +C + 380 CALL DSTEPS(DF,NEQ,YY,X,H,EPS,WT,START,HOLD,KORD,KOLD,CRASH,PHI,P, + 1 YP,PSI,ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND,KSTEPS, + 2 TWOU,FOURU,XOLD,KPREV,IVC,IV,KGI,GI,RPAR,IPAR) +C +C....................................................................... +C + IF(.NOT.CRASH) GO TO 420 +C +C TOLERANCES TOO SMALL + IDID = -2 + RTOL(1) = EPS*RTOL(1) + ATOL(1) = EPS*ATOL(1) + IF (INFO(2) .EQ. 0) GO TO 400 + DO 390 L = 2,NEQ + RTOL(L) = EPS*RTOL(L) + 390 ATOL(L) = EPS*ATOL(L) + 400 DO 410 L = 1,NEQ + Y(L) = YY(L) + 410 YPOUT(L) = YP(L) + T = X + TOLD = T + INFO(1) = -1 + INTOUT = .FALSE. + RETURN +C +C (STIFFNESS TEST) COUNT NUMBER OF CONSECUTIVE STEPS TAKEN WITH THE +C ORDER OF THE METHOD BEING LESS OR EQUAL TO FOUR +C + 420 KLE4 = KLE4 + 1 + IF(KOLD .GT. 4) KLE4 = 0 + IF(KLE4 .GE. 50) STIFF = .TRUE. + INTOUT = .TRUE. + GO TO 250 + END diff --git a/SLATEC/src/ddot.f b/SLATEC/src/ddot.f new file mode 100644 index 0000000..1fe83eb --- /dev/null +++ b/SLATEC/src/ddot.f @@ -0,0 +1,89 @@ +*DECK DDOT + DOUBLE PRECISION FUNCTION DDOT (N, DX, INCX, DY, INCY) +C***BEGIN PROLOGUE DDOT +C***PURPOSE Compute the inner product of two vectors. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A4 +C***TYPE DOUBLE PRECISION (SDOT-S, DDOT-D, CDOTU-C) +C***KEYWORDS BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C DY double precision vector with N elements +C INCY storage spacing between elements of DY +C +C --Output-- +C DDOT double precision dot product (zero if N .LE. 0) +C +C Returns the dot product of double precision DX and DY. +C DDOT = sum for I = 0 to N-1 of DX(LX+I*INCX) * DY(LY+I*INCY), +C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is +C defined in a similar way using INCY. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920310 Corrected definition of LX in DESCRIPTION. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DDOT + DOUBLE PRECISION DX(*), DY(*) +C***FIRST EXECUTABLE STATEMENT DDOT + DDOT = 0.0D0 + IF (N .LE. 0) RETURN + IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 +C +C Code for unequal or nonpositive increments. +C + 5 IX = 1 + IY = 1 + IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 + IF (INCY .LT. 0) IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DDOT = DDOT + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C Code for both increments equal to 1. +C +C Clean-up loop so remaining vector length is a multiple of 5. +C + 20 M = MOD(N,5) + IF (M .EQ. 0) GO TO 40 + DO 30 I = 1,M + DDOT = DDOT + DX(I)*DY(I) + 30 CONTINUE + IF (N .LT. 5) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + DX(I+2)*DY(I+2) + + 1 DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) + 50 CONTINUE + RETURN +C +C Code for equal, positive, non-unit increments. +C + 60 NS = N*INCX + DO 70 I = 1,NS,INCX + DDOT = DDOT + DX(I)*DY(I) + 70 CONTINUE + RETURN + END diff --git a/SLATEC/src/dfehl.f b/SLATEC/src/dfehl.f new file mode 100644 index 0000000..fcfb032 --- /dev/null +++ b/SLATEC/src/dfehl.f @@ -0,0 +1,107 @@ +*DECK DFEHL + SUBROUTINE DFEHL (DF, NEQ, T, Y, H, YP, F1, F2, F3, F4, F5, YS, + + RPAR, IPAR) +C***BEGIN PROLOGUE DFEHL +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (DEFEHL-S, DFEHL-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C Fehlberg Fourth-Fifth Order Runge-Kutta Method +C ********************************************************************** +C +C DFEHL integrates a system of NEQ first order +C ordinary differential equations of the form +C DU/DX = DF(X,U) +C over one step when the vector Y(*) of initial values for U(*) and +C the vector YP(*) of initial derivatives, satisfying YP = DF(T,Y), +C are given at the starting point X=T. +C +C DFEHL advances the solution over the fixed step H and returns +C the fifth order (sixth order accurate locally) solution +C approximation at T+H in the array YS(*). +C F1,---,F5 are arrays of dimension NEQ which are needed +C for internal storage. +C The formulas have been grouped to control loss of significance. +C DFEHL should be called with an H not smaller than 13 units of +C roundoff in T so that the various independent arguments can be +C distinguished. +C +C This subroutine has been written with all variables and statement +C numbers entirely compatible with DRKFS. For greater efficiency, +C the call to DFEHL can be replaced by the module beginning with +C line 222 and extending to the last line just before the return +C statement. +C +C ********************************************************************** +C +C***SEE ALSO DDERKF +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DFEHL +C + INTEGER IPAR, K, NEQ + DOUBLE PRECISION CH, F1, F2, F3, F4, F5, H, RPAR, T, Y, YP, YS + DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), + 1 YS(*),RPAR(*),IPAR(*) +C +C***FIRST EXECUTABLE STATEMENT DFEHL + CH = H/4.0D0 + DO 10 K = 1, NEQ + YS(K) = Y(K) + CH*YP(K) + 10 CONTINUE + CALL DF(T+CH,YS,F1,RPAR,IPAR) +C + CH = 3.0D0*H/32.0D0 + DO 20 K = 1, NEQ + YS(K) = Y(K) + CH*(YP(K) + 3.0D0*F1(K)) + 20 CONTINUE + CALL DF(T+3.0D0*H/8.0D0,YS,F2,RPAR,IPAR) +C + CH = H/2197.0D0 + DO 30 K = 1, NEQ + YS(K) = Y(K) + 1 + CH + 2 *(1932.0D0*YP(K) + (7296.0D0*F2(K) - 7200.0D0*F1(K))) + 30 CONTINUE + CALL DF(T+12.0D0*H/13.0D0,YS,F3,RPAR,IPAR) +C + CH = H/4104.0D0 + DO 40 K = 1, NEQ + YS(K) = Y(K) + 1 + CH + 2 *((8341.0D0*YP(K) - 845.0D0*F3(K)) + 3 + (29440.0D0*F2(K) - 32832.0D0*F1(K))) + 40 CONTINUE + CALL DF(T+H,YS,F4,RPAR,IPAR) +C + CH = H/20520.0D0 + DO 50 K = 1, NEQ + YS(K) = Y(K) + 1 + CH + 2 *((-6080.0D0*YP(K) + 3 + (9295.0D0*F3(K) - 5643.0D0*F4(K))) + 4 + (41040.0D0*F1(K) - 28352.0D0*F2(K))) + 50 CONTINUE + CALL DF(T+H/2.0D0,YS,F5,RPAR,IPAR) +C +C COMPUTE APPROXIMATE SOLUTION AT T+H +C + CH = H/7618050.0D0 + DO 60 K = 1, NEQ + YS(K) = Y(K) + 1 + CH + 2 *((902880.0D0*YP(K) + 3 + (3855735.0D0*F3(K) - 1371249.0D0*F4(K))) + 4 + (3953664.0D0*F2(K) + 277020.0D0*F5(K))) + 60 CONTINUE +C + RETURN + END diff --git a/SLATEC/src/dfzero.f b/SLATEC/src/dfzero.f new file mode 100644 index 0000000..5943818 --- /dev/null +++ b/SLATEC/src/dfzero.f @@ -0,0 +1,225 @@ +*DECK DFZERO + SUBROUTINE DFZERO (F, B, C, R, RE, AE, IFLAG) +C***BEGIN PROLOGUE DFZERO +C***PURPOSE Search for a zero of a function F(X) in a given interval +C (B,C). It is designed primarily for problems where F(B) +C and F(C) have opposite signs. +C***LIBRARY SLATEC +C***CATEGORY F1B +C***TYPE DOUBLE PRECISION (FZERO-S, DFZERO-D) +C***KEYWORDS BISECTION, NONLINEAR, ROOTS, ZEROS +C***AUTHOR Shampine, L. F., (SNLA) +C Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DFZERO searches for a zero of a DOUBLE PRECISION function F(X) +C between the given DOUBLE PRECISION values B and C until the width +C of the interval (B,C) has collapsed to within a tolerance +C specified by the stopping criterion, +C ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). +C The method used is an efficient combination of bisection and the +C secant rule and is due to T. J. Dekker. +C +C Description Of Arguments +C +C F :EXT - Name of the DOUBLE PRECISION external function. This +C name must be in an EXTERNAL statement in the calling +C program. F must be a function of one DOUBLE +C PRECISION argument. +C +C B :INOUT - One end of the DOUBLE PRECISION interval (B,C). The +C value returned for B usually is the better +C approximation to a zero of F. +C +C C :INOUT - The other end of the DOUBLE PRECISION interval (B,C) +C +C R :IN - A (better) DOUBLE PRECISION guess of a zero of F +C which could help in speeding up convergence. If F(B) +C and F(R) have opposite signs, a root will be found in +C the interval (B,R); if not, but F(R) and F(C) have +C opposite signs, a root will be found in the interval +C (R,C); otherwise, the interval (B,C) will be +C searched for a possible root. When no better guess +C is known, it is recommended that R be set to B or C, +C since if R is not interior to the interval (B,C), it +C will be ignored. +C +C RE :IN - Relative error used for RW in the stopping criterion. +C If the requested RE is less than machine precision, +C then RW is set to approximately machine precision. +C +C AE :IN - Absolute error used in the stopping criterion. If +C the given interval (B,C) contains the origin, then a +C nonzero value should be chosen for AE. +C +C IFLAG :OUT - A status code. User must check IFLAG after each +C call. Control returns to the user from DFZERO in all +C cases. +C +C 1 B is within the requested tolerance of a zero. +C The interval (B,C) collapsed to the requested +C tolerance, the function changes sign in (B,C), and +C F(X) decreased in magnitude as (B,C) collapsed. +C +C 2 F(B) = 0. However, the interval (B,C) may not have +C collapsed to the requested tolerance. +C +C 3 B may be near a singular point of F(X). +C The interval (B,C) collapsed to the requested tol- +C erance and the function changes sign in (B,C), but +C F(X) increased in magnitude as (B,C) collapsed, i.e. +C ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) +C +C 4 No change in sign of F(X) was found although the +C interval (B,C) collapsed to the requested tolerance. +C The user must examine this case and decide whether +C B is near a local minimum of F(X), or B is near a +C zero of even multiplicity, or neither of these. +C +C 5 Too many (.GT. 500) function evaluations used. +C +C***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving +C code, Report SC-TM-70-631, Sandia Laboratories, +C September 1970. +C T. J. Dekker, Finding a zero by means of successive +C linear interpolation, Constructive Aspects of the +C Fundamental Theorem of Algebra, edited by B. Dejon +C and P. Henrici, Wiley-Interscience, 1969. +C***ROUTINES CALLED D1MACH +C***REVISION HISTORY (YYMMDD) +C 700901 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DFZERO + DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,D1MACH,ER, + + F,FA,FB,FC,FX,FZ,P,Q,R,RE,RW,T,TOL,Z + INTEGER IC,IFLAG,KOUNT +C +C***FIRST EXECUTABLE STATEMENT DFZERO +C +C ER is two times the computer unit roundoff value which is defined +C here by the function D1MACH. +C + ER = 2.0D0 * D1MACH(4) +C +C Initialize. +C + Z = R + IF (R .LE. MIN(B,C) .OR. R .GE. MAX(B,C)) Z = C + RW = MAX(RE,ER) + AW = MAX(AE,0.D0) + IC = 0 + T = Z + FZ = F(T) + FC = FZ + T = B + FB = F(T) + KOUNT = 2 + IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FB)) GO TO 1 + C = Z + GO TO 2 + 1 IF (Z .EQ. C) GO TO 2 + T = C + FC = F(T) + KOUNT = 3 + IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FC)) GO TO 2 + B = Z + FB = FZ + 2 A = C + FA = FC + ACBS = ABS(B-C) + FX = MAX(ABS(FB),ABS(FC)) +C + 3 IF (ABS(FC) .GE. ABS(FB)) GO TO 4 +C +C Perform interchange. +C + A = B + FA = FB + B = C + FB = FC + C = A + FC = FA +C + 4 CMB = 0.5D0*(C-B) + ACMB = ABS(CMB) + TOL = RW*ABS(B) + AW +C +C Test stopping criterion and function count. +C + IF (ACMB .LE. TOL) GO TO 10 + IF (FB .EQ. 0.D0) GO TO 11 + IF (KOUNT .GE. 500) GO TO 14 +C +C Calculate new iterate implicitly as B+P/Q, where we arrange +C P .GE. 0. The implicit form is used to prevent overflow. +C + P = (B-A)*FB + Q = FA - FB + IF (P .GE. 0.D0) GO TO 5 + P = -P + Q = -Q +C +C Update A and check for satisfactory reduction in the size of the +C bracketing interval. If not, perform bisection. +C + 5 A = B + FA = FB + IC = IC + 1 + IF (IC .LT. 4) GO TO 6 + IF (8.0D0*ACMB .GE. ACBS) GO TO 8 + IC = 0 + ACBS = ACMB +C +C Test for too small a change. +C + 6 IF (P .GT. ABS(Q)*TOL) GO TO 7 +C +C Increment by TOLerance. +C + B = B + SIGN(TOL,CMB) + GO TO 9 +C +C Root ought to be between B and (C+B)/2. +C + 7 IF (P .GE. CMB*Q) GO TO 8 +C +C Use secant rule. +C + B = B + P/Q + GO TO 9 +C +C Use bisection (C+B)/2. +C + 8 B = B + CMB +C +C Have completed computation for new iterate B. +C + 9 T = B + FB = F(T) + KOUNT = KOUNT + 1 +C +C Decide whether next step is interpolation or extrapolation. +C + IF (SIGN(1.0D0,FB) .NE. SIGN(1.0D0,FC)) GO TO 3 + C = A + FC = FA + GO TO 3 +C +C Finished. Process results for proper setting of IFLAG. +C + 10 IF (SIGN(1.0D0,FB) .EQ. SIGN(1.0D0,FC)) GO TO 13 + IF (ABS(FB) .GT. FX) GO TO 12 + IFLAG = 1 + RETURN + 11 IFLAG = 2 + RETURN + 12 IFLAG = 3 + RETURN + 13 IFLAG = 4 + RETURN + 14 IFLAG = 5 + RETURN + END diff --git a/SLATEC/src/dgaus8.f b/SLATEC/src/dgaus8.f new file mode 100644 index 0000000..ad4a1cb --- /dev/null +++ b/SLATEC/src/dgaus8.f @@ -0,0 +1,201 @@ +*DECK DGAUS8 + SUBROUTINE DGAUS8 (FUN, A, B, ERR, ANS, IERR) +C***BEGIN PROLOGUE DGAUS8 +C***PURPOSE Integrate a real function of one variable over a finite +C interval using an adaptive 8-point Legendre-Gauss +C algorithm. Intended primarily for high accuracy +C integration or integration of smooth functions. +C***LIBRARY SLATEC +C***CATEGORY H2A1A1 +C***TYPE DOUBLE PRECISION (GAUS8-S, DGAUS8-D) +C***KEYWORDS ADAPTIVE QUADRATURE, AUTOMATIC INTEGRATOR, +C GAUSS QUADRATURE, NUMERICAL INTEGRATION +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract *** a DOUBLE PRECISION routine *** +C DGAUS8 integrates real functions of one variable over finite +C intervals using an adaptive 8-point Legendre-Gauss algorithm. +C DGAUS8 is intended primarily for high accuracy integration +C or integration of smooth functions. +C +C The maximum number of significant digits obtainable in ANS +C is the smaller of 18 and the number of digits carried in +C double precision arithmetic. +C +C Description of Arguments +C +C Input--* FUN, A, B, ERR are DOUBLE PRECISION * +C FUN - name of external function to be integrated. This name +C must be in an EXTERNAL statement in the calling program. +C FUN must be a DOUBLE PRECISION function of one DOUBLE +C PRECISION argument. The value of the argument to FUN +C is the variable of integration which ranges from A to B. +C A - lower limit of integration +C B - upper limit of integration (may be less than A) +C ERR - is a requested pseudorelative error tolerance. Normally +C pick a value of ABS(ERR) so that DTOL .LT. ABS(ERR) .LE. +C 1.0D-3 where DTOL is the larger of 1.0D-18 and the +C double precision unit roundoff D1MACH(4). ANS will +C normally have no more error than ABS(ERR) times the +C integral of the absolute value of FUN(X). Usually, +C smaller values of ERR yield more accuracy and require +C more function evaluations. +C +C A negative value for ERR causes an estimate of the +C absolute error in ANS to be returned in ERR. Note that +C ERR must be a variable (not a constant) in this case. +C Note also that the user must reset the value of ERR +C before making any more calls that use the variable ERR. +C +C Output--* ERR,ANS are double precision * +C ERR - will be an estimate of the absolute error in ANS if the +C input value of ERR was negative. (ERR is unchanged if +C the input value of ERR was non-negative.) The estimated +C error is solely for information to the user and should +C not be used as a correction to the computed integral. +C ANS - computed value of integral +C IERR- a status code +C --Normal codes +C 1 ANS most likely meets requested error tolerance, +C or A=B. +C -1 A and B are too nearly equal to allow normal +C integration. ANS is set to zero. +C --Abnormal code +C 2 ANS probably does not meet requested error tolerance. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, I1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 810223 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 890911 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C***END PROLOGUE DGAUS8 + INTEGER IERR, K, KML, KMX, L, LMN, LMX, LR, MXL, NBITS, + 1 NIB, NLMN, NLMX + INTEGER I1MACH + DOUBLE PRECISION A,AA,AE,ANIB,ANS,AREA,B,C,CE,EE,EF, + 1 EPS, ERR, EST, GL, GLR, GR, HH, SQ2, TOL, VL, VR, W1, W2, W3, + 2 W4, X1, X2, X3, X4, X, H + DOUBLE PRECISION D1MACH, G8, FUN + DIMENSION AA(60), HH(60), LR(60), VL(60), GR(60) + SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, + 1 NLMN, KMX, KML + DATA X1, X2, X3, X4/ + 1 1.83434642495649805D-01, 5.25532409916328986D-01, + 2 7.96666477413626740D-01, 9.60289856497536232D-01/ + DATA W1, W2, W3, W4/ + 1 3.62683783378361983D-01, 3.13706645877887287D-01, + 2 2.22381034453374471D-01, 1.01228536290376259D-01/ + DATA SQ2/1.41421356D0/ + DATA NLMN/1/,KMX/5000/,KML/6/ + G8(X,H)=H*((W1*(FUN(X-X1*H) + FUN(X+X1*H)) + 1 +W2*(FUN(X-X2*H) + FUN(X+X2*H))) + 2 +(W3*(FUN(X-X3*H) + FUN(X+X3*H)) + 3 +W4*(FUN(X-X4*H) + FUN(X+X4*H)))) +C***FIRST EXECUTABLE STATEMENT DGAUS8 +C +C Initialize +C + K = I1MACH(14) + ANIB = D1MACH(5)*K/0.30102000D0 + NBITS = ANIB + NLMX = MIN(60,(NBITS*5)/8) + ANS = 0.0D0 + IERR = 1 + CE = 0.0D0 + IF (A .EQ. B) GO TO 140 + LMX = NLMX + LMN = NLMN + IF (B .EQ. 0.0D0) GO TO 10 + IF (SIGN(1.0D0,B)*A .LE. 0.0D0) GO TO 10 + C = ABS(1.0D0-A/B) + IF (C .GT. 0.1D0) GO TO 10 + IF (C .LE. 0.0D0) GO TO 140 + ANIB = 0.5D0 - LOG(C)/0.69314718D0 + NIB = ANIB + LMX = MIN(NLMX,NBITS-NIB-7) + IF (LMX .LT. 1) GO TO 130 + LMN = MIN(LMN,LMX) + 10 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS))/2.0D0 + IF (ERR .EQ. 0.0D0) TOL = SQRT(D1MACH(4)) + EPS = TOL + HH(1) = (B-A)/4.0D0 + AA(1) = A + LR(1) = 1 + L = 1 + EST = G8(AA(L)+2.0D0*HH(L),2.0D0*HH(L)) + K = 8 + AREA = ABS(EST) + EF = 0.5D0 + MXL = 0 +C +C Compute refined estimates, estimate the error, etc. +C + 20 GL = G8(AA(L)+HH(L),HH(L)) + GR(L) = G8(AA(L)+3.0D0*HH(L),HH(L)) + K = K + 16 + AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) +C IF (L .LT .LMN) GO TO 11 + GLR = GL + GR(L) + EE = ABS(EST-GLR)*EF + AE = MAX(EPS*AREA,TOL*ABS(GLR)) + IF (EE-AE) 40, 40, 50 + 30 MXL = 1 + 40 CE = CE + (EST-GLR) + IF (LR(L)) 60, 60, 80 +C +C Consider the left half of this level +C + 50 IF (K .GT. KMX) LMX = KML + IF (L .GE. LMX) GO TO 30 + L = L + 1 + EPS = EPS*0.5D0 + EF = EF/SQ2 + HH(L) = HH(L-1)*0.5D0 + LR(L) = -1 + AA(L) = AA(L-1) + EST = GL + GO TO 20 +C +C Proceed to right half at this level +C + 60 VL(L) = GLR + 70 EST = GR(L-1) + LR(L) = 1 + AA(L) = AA(L) + 4.0D0*HH(L) + GO TO 20 +C +C Return one level +C + 80 VR = GLR + 90 IF (L .LE. 1) GO TO 120 + L = L - 1 + EPS = EPS*2.0D0 + EF = EF*SQ2 + IF (LR(L)) 100, 100, 110 + 100 VL(L) = VL(L+1) + VR + GO TO 70 + 110 VR = VL(L+1) + VR + GO TO 90 +C +C Exit +C + 120 ANS = VR + IF ((MXL.EQ.0) .OR. (ABS(CE).LE.2.0D0*TOL*AREA)) GO TO 140 + IERR = 2 + CALL XERMSG ('SLATEC', 'DGAUS8', + + 'ANS is probably insufficiently accurate.', 3, 1) + GO TO 140 + 130 IERR = -1 + CALL XERMSG ('SLATEC', 'DGAUS8', + + 'A and B are too nearly equal to allow normal integration. $$' + + // 'ANS is set to zero and IERR to -1.', 1, -1) + 140 IF (ERR .LT. 0.0D0) ERR = CE + RETURN + END diff --git a/SLATEC/src/dgeco.f b/SLATEC/src/dgeco.f new file mode 100644 index 0000000..3f56183 --- /dev/null +++ b/SLATEC/src/dgeco.f @@ -0,0 +1,207 @@ +*DECK DGECO + SUBROUTINE DGECO (A, LDA, N, IPVT, RCOND, Z) +C***BEGIN PROLOGUE DGECO +C***PURPOSE Factor a matrix using Gaussian elimination and estimate +C the condition number of the matrix. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2A1 +C***TYPE DOUBLE PRECISION (SGECO-S, DGECO-D, CGECO-C) +C***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, +C MATRIX FACTORIZATION +C***AUTHOR Moler, C. B., (U. of New Mexico) +C***DESCRIPTION +C +C DGECO factors a double precision matrix by Gaussian elimination +C and estimates the condition of the matrix. +C +C If RCOND is not needed, DGEFA is slightly faster. +C To solve A*X = B , follow DGECO by DGESL. +C To compute INVERSE(A)*C , follow DGECO by DGESL. +C To compute DETERMINANT(A) , follow DGECO by DGEDI. +C To compute INVERSE(A) , follow DGECO by DGEDI. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the matrix to be factored. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C On Return +C +C A an upper triangular matrix and the multipliers +C which were used to obtain it. +C The factorization can be written A = L*U where +C L is a product of permutation and unit lower +C triangular matrices and U is upper triangular. +C +C IPVT INTEGER(N) +C an INTEGER vector of pivot indices. +C +C RCOND DOUBLE PRECISION +C an estimate of the reciprocal condition of A . +C For the system A*X = B , relative perturbations +C in A and B of size EPSILON may cause +C relative perturbations in X of size EPSILON/RCOND . +C If RCOND is so small that the logical expression +C 1.0 + RCOND .EQ. 1.0 +C is true, then A may be singular to working +C precision. In particular, RCOND is zero if +C exact singularity is detected or the estimate +C underflows. +C +C Z DOUBLE PRECISION(N) +C a work vector whose contents are usually unimportant. +C If A is close to a singular matrix, then Z is +C an approximate null vector in the sense that +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED DASUM, DAXPY, DDOT, DGEFA, DSCAL +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DGECO + INTEGER LDA,N,IPVT(*) + DOUBLE PRECISION A(LDA,*),Z(*) + DOUBLE PRECISION RCOND +C + DOUBLE PRECISION DDOT,EK,T,WK,WKM + DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM + INTEGER INFO,J,K,KB,KP1,L +C +C COMPUTE 1-NORM OF A +C +C***FIRST EXECUTABLE STATEMENT DGECO + ANORM = 0.0D0 + DO 10 J = 1, N + ANORM = MAX(ANORM,DASUM(N,A(1,J),1)) + 10 CONTINUE +C +C FACTOR +C + CALL DGEFA(A,LDA,N,IPVT,INFO) +C +C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . +C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE +C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE +C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID +C OVERFLOW. +C +C SOLVE TRANS(U)*W = E +C + EK = 1.0D0 + DO 20 J = 1, N + Z(J) = 0.0D0 + 20 CONTINUE + DO 100 K = 1, N + IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K)) + IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30 + S = ABS(A(K,K))/ABS(EK-Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 30 CONTINUE + WK = EK - Z(K) + WKM = -EK - Z(K) + S = ABS(WK) + SM = ABS(WKM) + IF (A(K,K) .EQ. 0.0D0) GO TO 40 + WK = WK/A(K,K) + WKM = WKM/A(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0D0 + WKM = 1.0D0 + 50 CONTINUE + KP1 = K + 1 + IF (KP1 .GT. N) GO TO 90 + DO 60 J = KP1, N + SM = SM + ABS(Z(J)+WKM*A(K,J)) + Z(J) = Z(J) + WK*A(K,J) + S = S + ABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + T = WKM - WK + WK = WKM + DO 70 J = KP1, N + Z(J) = Z(J) + T*A(K,J) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + Z(K) = WK + 100 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C +C SOLVE TRANS(L)*Y = W +C + DO 120 KB = 1, N + K = N + 1 - KB + IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) + IF (ABS(Z(K)) .LE. 1.0D0) GO TO 110 + S = 1.0D0/ABS(Z(K)) + CALL DSCAL(N,S,Z,1) + 110 CONTINUE + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + 120 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C + YNORM = 1.0D0 +C +C SOLVE L*V = Y +C + DO 140 K = 1, N + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) + IF (ABS(Z(K)) .LE. 1.0D0) GO TO 130 + S = 1.0D0/ABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 130 CONTINUE + 140 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C +C SOLVE U*Z = V +C + DO 160 KB = 1, N + K = N + 1 - KB + IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150 + S = ABS(A(K,K))/ABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 150 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + T = -Z(K) + CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) + 160 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C + IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM + IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END diff --git a/SLATEC/src/dgefa.f b/SLATEC/src/dgefa.f new file mode 100644 index 0000000..57d9105 --- /dev/null +++ b/SLATEC/src/dgefa.f @@ -0,0 +1,117 @@ +*DECK DGEFA + SUBROUTINE DGEFA (A, LDA, N, IPVT, INFO) +C***BEGIN PROLOGUE DGEFA +C***PURPOSE Factor a matrix using Gaussian elimination. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2A1 +C***TYPE DOUBLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) +C***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, +C MATRIX FACTORIZATION +C***AUTHOR Moler, C. B., (U. of New Mexico) +C***DESCRIPTION +C +C DGEFA factors a double precision matrix by Gaussian elimination. +C +C DGEFA is usually called by DGECO, but it can be called +C directly with a saving in time if RCOND is not needed. +C (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the matrix to be factored. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C On Return +C +C A an upper triangular matrix and the multipliers +C which were used to obtain it. +C The factorization can be written A = L*U where +C L is a product of permutation and unit lower +C triangular matrices and U is upper triangular. +C +C IPVT INTEGER(N) +C an integer vector of pivot indices. +C +C INFO INTEGER +C = 0 normal value. +C = K if U(K,K) .EQ. 0.0 . This is not an error +C condition for this subroutine, but it does +C indicate that DGESL or DGEDI will divide by zero +C if called. Use RCOND in DGECO for a reliable +C indication of singularity. +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DGEFA + INTEGER LDA,N,IPVT(*),INFO + DOUBLE PRECISION A(LDA,*) +C + DOUBLE PRECISION T + INTEGER IDAMAX,J,K,KP1,L,NM1 +C +C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +C +C***FIRST EXECUTABLE STATEMENT DGEFA + INFO = 0 + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 70 + DO 60 K = 1, NM1 + KP1 = K + 1 +C +C FIND L = PIVOT INDEX +C + L = IDAMAX(N-K+1,A(K,K),1) + K - 1 + IPVT(K) = L +C +C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +C + IF (A(L,K) .EQ. 0.0D0) GO TO 40 +C +C INTERCHANGE IF NECESSARY +C + IF (L .EQ. K) GO TO 10 + T = A(L,K) + A(L,K) = A(K,K) + A(K,K) = T + 10 CONTINUE +C +C COMPUTE MULTIPLIERS +C + T = -1.0D0/A(K,K) + CALL DSCAL(N-K,T,A(K+1,K),1) +C +C ROW ELIMINATION WITH COLUMN INDEXING +C + DO 30 J = KP1, N + T = A(L,J) + IF (L .EQ. K) GO TO 20 + A(L,J) = A(K,J) + A(K,J) = T + 20 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) + 30 CONTINUE + GO TO 50 + 40 CONTINUE + INFO = K + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IPVT(N) = N + IF (A(N,N) .EQ. 0.0D0) INFO = N + RETURN + END diff --git a/SLATEC/src/dgefs.f b/SLATEC/src/dgefs.f new file mode 100644 index 0000000..3dc6fb0 --- /dev/null +++ b/SLATEC/src/dgefs.f @@ -0,0 +1,165 @@ +*DECK DGEFS + SUBROUTINE DGEFS (A, LDA, N, V, ITASK, IND, WORK, IWORK) +C***BEGIN PROLOGUE DGEFS +C***PURPOSE Solve a general system of linear equations. +C***LIBRARY SLATEC +C***CATEGORY D2A1 +C***TYPE DOUBLE PRECISION (SGEFS-S, DGEFS-D, CGEFS-C) +C***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, +C GENERAL SYSTEM OF LINEAR EQUATIONS +C***AUTHOR Voorhees, E. A., (LANL) +C***DESCRIPTION +C +C Subroutine DGEFS solves a general NxN system of double +C precision linear equations using LINPACK subroutines DGECO +C and DGESL. That is, if A is an NxN double precision matrix +C and if X and B are double precision N-vectors, then DGEFS +C solves the equation +C +C A*X=B. +C +C The matrix A is first factored into upper and lower tri- +C angular matrices U and L using partial pivoting. These +C factors and the pivoting information are used to find the +C solution vector X. An approximate condition number is +C calculated to provide a rough estimate of the number of +C digits of accuracy in the computed solution. +C +C If the equation A*X=B is to be solved for more than one vector +C B, the factoring of A does not need to be performed again and +C the option to only solve (ITASK.GT.1) will be faster for +C the succeeding solutions. In this case, the contents of A, +C LDA, N and IWORK must not have been altered by the user follow- +C ing factorization (ITASK=1). IND will not be changed by DGEFS +C in this case. +C +C Argument Description *** +C +C A DOUBLE PRECISION(LDA,N) +C on entry, the doubly subscripted array with dimension +C (LDA,N) which contains the coefficient matrix. +C on return, an upper triangular matrix U and the +C multipliers necessary to construct a matrix L +C so that A=L*U. +C LDA INTEGER +C the leading dimension of the array A. LDA must be great- +C er than or equal to N. (terminal error message IND=-1) +C N INTEGER +C the order of the matrix A. The first N elements of +C the array A are the elements of the first column of +C the matrix A. N must be greater than or equal to 1. +C (terminal error message IND=-2) +C V DOUBLE PRECISION(N) +C on entry, the singly subscripted array(vector) of di- +C mension N which contains the right hand side B of a +C system of simultaneous linear equations A*X=B. +C on return, V contains the solution vector, X . +C ITASK INTEGER +C If ITASK=1, the matrix A is factored and then the +C linear equation is solved. +C If ITASK .GT. 1, the equation is solved using the existing +C factored matrix A and IWORK. +C If ITASK .LT. 1, then terminal error message IND=-3 is +C printed. +C IND INTEGER +C GT. 0 IND is a rough estimate of the number of digits +C of accuracy in the solution, X. +C LT. 0 see error message corresponding to IND below. +C WORK DOUBLE PRECISION(N) +C a singly subscripted array of dimension at least N. +C IWORK INTEGER(N) +C a singly subscripted array of dimension at least N. +C +C Error Messages Printed *** +C +C IND=-1 terminal N is greater than LDA. +C IND=-2 terminal N is less than 1. +C IND=-3 terminal ITASK is less than 1. +C IND=-4 terminal The matrix A is computationally singular. +C A solution has not been computed. +C IND=-10 warning The solution has no apparent significance. +C The solution may be inaccurate or the matrix +C A may be poorly scaled. +C +C Note- The above terminal(*fatal*) error messages are +C designed to be handled by XERMSG in which +C LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 +C for warning error messages from XERMSG. Unless +C the user provides otherwise, an error message +C will be printed followed by an abort. +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED D1MACH, DGECO, DGESL, XERMSG +C***REVISION HISTORY (YYMMDD) +C 800326 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900510 Convert XERRWV calls to XERMSG calls. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DGEFS +C + INTEGER LDA,N,ITASK,IND,IWORK(*) + DOUBLE PRECISION A(LDA,*),V(*),WORK(*),D1MACH + DOUBLE PRECISION RCOND + CHARACTER*8 XERN1, XERN2 +C***FIRST EXECUTABLE STATEMENT DGEFS + IF (LDA.LT.N) THEN + IND = -1 + WRITE (XERN1, '(I8)') LDA + WRITE (XERN2, '(I8)') N + CALL XERMSG ('SLATEC', 'DGEFS', 'LDA = ' // XERN1 // + * ' IS LESS THAN N = ' // XERN2, -1, 1) + RETURN + ENDIF +C + IF (N.LE.0) THEN + IND = -2 + WRITE (XERN1, '(I8)') N + CALL XERMSG ('SLATEC', 'DGEFS', 'N = ' // XERN1 // + * ' IS LESS THAN 1', -2, 1) + RETURN + ENDIF +C + IF (ITASK.LT.1) THEN + IND = -3 + WRITE (XERN1, '(I8)') ITASK + CALL XERMSG ('SLATEC', 'DGEFS', 'ITASK = ' // XERN1 // + * ' IS LESS THAN 1', -3, 1) + RETURN + ENDIF +C + IF (ITASK.EQ.1) THEN +C +C FACTOR MATRIX A INTO LU +C + CALL DGECO(A,LDA,N,IWORK,RCOND,WORK) +C +C CHECK FOR COMPUTATIONALLY SINGULAR MATRIX +C + IF (RCOND.EQ.0.0D0) THEN + IND = -4 + CALL XERMSG ('SLATEC', 'DGEFS', + * 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) + RETURN + ENDIF +C +C COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) +C AND CHECK FOR IND GREATER THAN ZERO +C + IND = -LOG10(D1MACH(4)/RCOND) + IF (IND.LE.0) THEN + IND=-10 + CALL XERMSG ('SLATEC', 'DGEFS', + * 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) + ENDIF + ENDIF +C +C SOLVE AFTER FACTORING +C + CALL DGESL(A,LDA,N,IWORK,V,0) + RETURN + END diff --git a/SLATEC/src/dgesl.f b/SLATEC/src/dgesl.f new file mode 100644 index 0000000..0059359 --- /dev/null +++ b/SLATEC/src/dgesl.f @@ -0,0 +1,131 @@ +*DECK DGESL + SUBROUTINE DGESL (A, LDA, N, IPVT, B, JOB) +C***BEGIN PROLOGUE DGESL +C***PURPOSE Solve the real system A*X=B or TRANS(A)*X=B using the +C factors computed by DGECO or DGEFA. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2A1 +C***TYPE DOUBLE PRECISION (SGESL-S, DGESL-D, CGESL-C) +C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE +C***AUTHOR Moler, C. B., (U. of New Mexico) +C***DESCRIPTION +C +C DGESL solves the double precision system +C A * X = B or TRANS(A) * X = B +C using the factors computed by DGECO or DGEFA. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the output from DGECO or DGEFA. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C IPVT INTEGER(N) +C the pivot vector from DGECO or DGEFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C JOB INTEGER +C = 0 to solve A*X = B , +C = nonzero to solve TRANS(A)*X = B where +C TRANS(A) is the transpose. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero will occur if the input factor contains a +C zero on the diagonal. Technically this indicates singularity +C but it is often caused by improper arguments or improper +C setting of LDA . It will not occur if the subroutines are +C called correctly and if DGECO has set RCOND .GT. 0.0 +C or DGEFA has set INFO .EQ. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) +C IF (RCOND is too small) GO TO ... +C DO 10 J = 1, P +C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) +C 10 CONTINUE +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED DAXPY, DDOT +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DGESL + INTEGER LDA,N,IPVT(*),JOB + DOUBLE PRECISION A(LDA,*),B(*) +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,NM1 +C***FIRST EXECUTABLE STATEMENT DGESL + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , SOLVE A * X = B +C FIRST SOLVE L*Y = B +C + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW SOLVE U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/A(K,K) + T = -B(K) + CALL DAXPY(K-1,T,A(1,K),1,B(1),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, SOLVE TRANS(A) * X = B +C FIRST SOLVE TRANS(U)*Y = B +C + DO 60 K = 1, N + T = DDOT(K-1,A(1,K),1,B(1),1) + B(K) = (B(K) - T)/A(K,K) + 60 CONTINUE +C +C NOW SOLVE TRANS(L)*X = Y +C + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END diff --git a/SLATEC/src/dhstrt.f b/SLATEC/src/dhstrt.f new file mode 100644 index 0000000..965d7ec --- /dev/null +++ b/SLATEC/src/dhstrt.f @@ -0,0 +1,350 @@ +*DECK DHSTRT + SUBROUTINE DHSTRT (DF, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, + + BIG, SPY, PV, YP, SF, RPAR, IPAR, H) +C***BEGIN PROLOGUE DHSTRT +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (HSTART-S, DHSTRT-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DHSTRT computes a starting step size to be used in solving initial +C value problems in ordinary differential equations. +C +C ********************************************************************** +C ABSTRACT +C +C Subroutine DHSTRT computes a starting step size to be used by an +C initial value method in solving ordinary differential equations. +C It is based on an estimate of the local Lipschitz constant for the +C differential equation (lower bound on a norm of the Jacobian) , +C a bound on the differential equation (first derivative) , and +C a bound on the partial derivative of the equation with respect to +C the independent variable. +C (all approximated near the initial point A) +C +C Subroutine DHSTRT uses a function subprogram DHVNRM for computing +C a vector norm. The maximum norm is presently utilized though it +C can easily be replaced by any other vector norm. It is presumed +C that any replacement norm routine would be carefully coded to +C prevent unnecessary underflows or overflows from occurring, and +C also, would not alter the vector or number of components. +C +C ********************************************************************** +C On input you must provide the following +C +C DF -- This is a subroutine of the form +C DF(X,U,UPRIME,RPAR,IPAR) +C which defines the system of first order differential +C equations to be solved. For the given values of X and the +C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must +C evaluate the NEQ components of the system of differential +C equations DU/DX=DF(X,U) and store the derivatives in the +C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for +C equations I=1,...,NEQ. +C +C Subroutine DF must not alter X or U(*). You must declare +C the name DF in an external statement in your program that +C calls DHSTRT. You must dimension U and UPRIME in DF. +C +C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C program and subroutine DF. They are not used or altered by +C DHSTRT. If you do not need RPAR or IPAR, ignore these +C parameters by treating them as dummy arguments. If you do +C choose to use them, dimension them in your program and in +C DF as arrays of appropriate length. +C +C NEQ -- This is the number of (first order) differential equations +C to be integrated. +C +C A -- This is the initial point of integration. +C +C B -- This is a value of the independent variable used to define +C the direction of integration. A reasonable choice is to +C set B to the first point at which a solution is desired. +C You can also use B, if necessary, to restrict the length +C of the first integration step because the algorithm will +C not compute a starting step length which is bigger than +C ABS(B-A), unless B has been chosen too close to A. +C (it is presumed that DHSTRT has been called with B +C different from A on the machine being used. Also see the +C discussion about the parameter SMALL.) +C +C Y(*) -- This is the vector of initial values of the NEQ solution +C components at the initial point A. +C +C YPRIME(*) -- This is the vector of derivatives of the NEQ +C solution components at the initial point A. +C (defined by the differential equations in subroutine DF) +C +C ETOL -- This is the vector of error tolerances corresponding to +C the NEQ solution components. It is assumed that all +C elements are positive. Following the first integration +C step, the tolerances are expected to be used by the +C integrator in an error test which roughly requires that +C ABS(LOCAL ERROR) .LE. ETOL +C for each vector component. +C +C MORDER -- This is the order of the formula which will be used by +C the initial value method for taking the first integration +C step. +C +C SMALL -- This is a small positive machine dependent constant +C which is used for protecting against computations with +C numbers which are too small relative to the precision of +C floating point arithmetic. SMALL should be set to +C (approximately) the smallest positive DOUBLE PRECISION +C number such that (1.+SMALL) .GT. 1. on the machine being +C used. The quantity SMALL**(3/8) is used in computing +C increments of variables for approximating derivatives by +C differences. Also the algorithm will not compute a +C starting step length which is smaller than +C 100*SMALL*ABS(A). +C +C BIG -- This is a large positive machine dependent constant which +C is used for preventing machine overflows. A reasonable +C choice is to set big to (approximately) the square root of +C the largest DOUBLE PRECISION number which can be held in +C the machine. +C +C SPY(*),PV(*),YP(*),SF(*) -- These are DOUBLE PRECISION work +C arrays of length NEQ which provide the routine with needed +C storage space. +C +C RPAR,IPAR -- These are parameter arrays, of DOUBLE PRECISION and +C INTEGER type, respectively, which can be used for +C communication between your program and the DF subroutine. +C They are not used or altered by DHSTRT. +C +C ********************************************************************** +C On Output (after the return from DHSTRT), +C +C H -- is an appropriate starting step size to be attempted by the +C differential equation method. +C +C All parameters in the call list remain unchanged except for +C the working arrays SPY(*),PV(*),YP(*), and SF(*). +C +C ********************************************************************** +C +C***SEE ALSO DDEABM, DDEBDF, DDERKF +C***ROUTINES CALLED DHVNRM +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DHSTRT +C + INTEGER IPAR, J, K, LK, MORDER, NEQ + DOUBLE PRECISION A, ABSDX, B, BIG, DA, DELF, DELY, + 1 DFDUB, DFDXB, DHVNRM, + 2 DX, DY, ETOL, FBND, H, PV, RELPER, RPAR, SF, SMALL, SPY, + 3 SRYDPB, TOLEXP, TOLMIN, TOLP, TOLSUM, Y, YDPB, YP, YPRIME + DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*), + 1 SF(*),RPAR(*),IPAR(*) + EXTERNAL DF +C +C .................................................................. +C +C BEGIN BLOCK PERMITTING ...EXITS TO 160 +C***FIRST EXECUTABLE STATEMENT DHSTRT + DX = B - A + ABSDX = ABS(DX) + RELPER = SMALL**0.375D0 +C +C ............................................................... +C +C COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL +C DERIVATIVE OF THE EQUATION WITH RESPECT TO THE +C INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. +C ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE +C LOCALLY. +C + DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX), + 1 100.0D0*SMALL*ABS(A)),DX) + IF (DA .EQ. 0.0D0) DA = RELPER*DX + CALL DF(A+DA,Y,SF,RPAR,IPAR) + DO 10 J = 1, NEQ + YP(J) = SF(J) - YPRIME(J) + 10 CONTINUE + DELF = DHVNRM(YP,NEQ) + DFDXB = BIG + IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA) + FBND = DHVNRM(SF,NEQ) +C +C ............................................................... +C +C COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ +C CONSTANT FOR THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS +C ALSO REPRESENTS AN ESTIMATE OF THE NORM OF THE JACOBIAN +C LOCALLY. THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO +C ESTIMATE THE LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. +C THE FIRST PERTURBATION VECTOR IS BASED ON THE INITIAL +C DERIVATIVES AND DIRECTION OF INTEGRATION. THE SECOND +C PERTURBATION VECTOR IS FORMED USING ANOTHER EVALUATION OF +C THE DIFFERENTIAL EQUATION. THE THIRD PERTURBATION VECTOR +C IS FORMED USING PERTURBATIONS BASED ONLY ON THE INITIAL +C VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS CHANGED TO +C NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN +C INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT +C COMPONENTS OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE +C CONSISTENT WITH THE SLOPES OF LOCAL SOLUTION CURVES. +C ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST +C DERIVATIVE. +C +C PERTURBATION VECTOR SIZE IS HELD +C CONSTANT FOR ALL ITERATIONS. COMPUTE +C THIS CHANGE FROM THE +C SIZE OF THE VECTOR OF INITIAL +C VALUES. + DELY = RELPER*DHVNRM(Y,NEQ) + IF (DELY .EQ. 0.0D0) DELY = RELPER + DELY = SIGN(DELY,DX) + DELF = DHVNRM(YPRIME,NEQ) + FBND = MAX(FBND,DELF) + IF (DELF .EQ. 0.0D0) GO TO 30 +C USE INITIAL DERIVATIVES FOR FIRST PERTURBATION + DO 20 J = 1, NEQ + SPY(J) = YPRIME(J) + YP(J) = YPRIME(J) + 20 CONTINUE + GO TO 50 + 30 CONTINUE +C CANNOT HAVE A NULL PERTURBATION VECTOR + DO 40 J = 1, NEQ + SPY(J) = 0.0D0 + YP(J) = 1.0D0 + 40 CONTINUE + DELF = DHVNRM(YP,NEQ) + 50 CONTINUE +C + DFDUB = 0.0D0 + LK = MIN(NEQ+1,3) + DO 140 K = 1, LK +C DEFINE PERTURBED VECTOR OF INITIAL VALUES + DO 60 J = 1, NEQ + PV(J) = Y(J) + DELY*(YP(J)/DELF) + 60 CONTINUE + IF (K .EQ. 2) GO TO 80 +C EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED +C VECTOR AND COMPUTE CORRESPONDING DIFFERENCES + CALL DF(A,PV,YP,RPAR,IPAR) + DO 70 J = 1, NEQ + PV(J) = YP(J) - YPRIME(J) + 70 CONTINUE + GO TO 100 + 80 CONTINUE +C USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE +C IN COMPUTING ONE ESTIMATE + CALL DF(A+DA,PV,YP,RPAR,IPAR) + DO 90 J = 1, NEQ + PV(J) = YP(J) - SF(J) + 90 CONTINUE + 100 CONTINUE +C CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE +C AND A LOCAL LIPSCHITZ CONSTANT + FBND = MAX(FBND,DHVNRM(YP,NEQ)) + DELF = DHVNRM(PV,NEQ) +C ...EXIT + IF (DELF .GE. BIG*ABS(DELY)) GO TO 150 + DFDUB = MAX(DFDUB,DELF/ABS(DELY)) +C ......EXIT + IF (K .EQ. LK) GO TO 160 +C CHOOSE NEXT PERTURBATION VECTOR + IF (DELF .EQ. 0.0D0) DELF = 1.0D0 + DO 130 J = 1, NEQ + IF (K .EQ. 2) GO TO 110 + DY = ABS(PV(J)) + IF (DY .EQ. 0.0D0) DY = DELF + GO TO 120 + 110 CONTINUE + DY = Y(J) + IF (DY .EQ. 0.0D0) DY = DELY/RELPER + 120 CONTINUE + IF (SPY(J) .EQ. 0.0D0) SPY(J) = YP(J) + IF (SPY(J) .NE. 0.0D0) DY = SIGN(DY,SPY(J)) + YP(J) = DY + 130 CONTINUE + DELF = DHVNRM(YP,NEQ) + 140 CONTINUE + 150 CONTINUE +C +C PROTECT AGAINST AN OVERFLOW + DFDUB = BIG + 160 CONTINUE +C +C .................................................................. +C +C COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE +C + YDPB = DFDXB + DFDUB*FBND +C +C .................................................................. +C +C DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP +C SIZE IS TO BE BASED. A VALUE IN THE MIDDLE OF THE ERROR +C TOLERANCE RANGE IS SELECTED. +C + TOLMIN = BIG + TOLSUM = 0.0D0 + DO 170 K = 1, NEQ + TOLEXP = LOG10(ETOL(K)) + TOLMIN = MIN(TOLMIN,TOLEXP) + TOLSUM = TOLSUM + TOLEXP + 170 CONTINUE + TOLP = 10.0D0**(0.5D0*(TOLSUM/NEQ + TOLMIN)/(MORDER+1)) +C +C .................................................................. +C +C COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND +C SECOND DERIVATIVE INFORMATION +C +C RESTRICT THE STEP LENGTH TO BE NOT BIGGER +C THAN ABS(B-A). (UNLESS B IS TOO CLOSE +C TO A) + H = ABSDX +C + IF (YDPB .NE. 0.0D0 .OR. FBND .NE. 0.0D0) GO TO 180 +C +C BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND +C DERIVATIVE TERM (YDPB) ARE ZERO + IF (TOLP .LT. 1.0D0) H = ABSDX*TOLP + GO TO 200 + 180 CONTINUE +C + IF (YDPB .NE. 0.0D0) GO TO 190 +C +C ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO + IF (TOLP .LT. FBND*ABSDX) H = TOLP/FBND + GO TO 200 + 190 CONTINUE +C +C SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO + SRYDPB = SQRT(0.5D0*YDPB) + IF (TOLP .LT. SRYDPB*ABSDX) H = TOLP/SRYDPB + 200 CONTINUE +C +C FURTHER RESTRICT THE STEP LENGTH TO BE NOT +C BIGGER THAN 1/DFDUB + IF (H*DFDUB .GT. 1.0D0) H = 1.0D0/DFDUB +C +C FINALLY, RESTRICT THE STEP LENGTH TO BE NOT +C SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF +C A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, +C THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE +C STEP LENGTH. + H = MAX(H,100.0D0*SMALL*ABS(A)) + IF (H .EQ. 0.0D0) H = SMALL*ABS(B) +C +C NOW SET DIRECTION OF INTEGRATION + H = SIGN(H,DX) +C + RETURN + END diff --git a/SLATEC/src/dhvnrm.f b/SLATEC/src/dhvnrm.f new file mode 100644 index 0000000..1128d9d --- /dev/null +++ b/SLATEC/src/dhvnrm.f @@ -0,0 +1,36 @@ +*DECK DHVNRM + DOUBLE PRECISION FUNCTION DHVNRM (V, NCOMP) +C***BEGIN PROLOGUE DHVNRM +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (HVNRM-S, DHVNRM-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C Compute the maximum norm of the vector V(*) of length NCOMP and +C return the result as DHVNRM +C +C***SEE ALSO DDEABM, DDEBDF, DDERKF +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891024 Changed routine name from DVNORM to DHVNRM. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DHVNRM +C + INTEGER K, NCOMP + DOUBLE PRECISION V + DIMENSION V(*) +C***FIRST EXECUTABLE STATEMENT DHVNRM + DHVNRM = 0.0D0 + DO 10 K = 1, NCOMP + DHVNRM = MAX(DHVNRM,ABS(V(K))) + 10 CONTINUE + RETURN + END diff --git a/SLATEC/src/dintp.f b/SLATEC/src/dintp.f new file mode 100644 index 0000000..594f8ea --- /dev/null +++ b/SLATEC/src/dintp.f @@ -0,0 +1,141 @@ +*DECK DINTP + SUBROUTINE DINTP (X, Y, XOUT, YOUT, YPOUT, NEQN, KOLD, PHI, IVC, + + IV, KGI, GI, ALPHA, OG, OW, OX, OY) +C***BEGIN PROLOGUE DINTP +C***PURPOSE Approximate the solution at XOUT by evaluating the +C polynomial computed in DSTEPS at XOUT. Must be used in +C conjunction with DSTEPS. +C***LIBRARY SLATEC (DEPAC) +C***CATEGORY I1A1B +C***TYPE DOUBLE PRECISION (SINTRP-S, DINTP-D) +C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, +C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR, +C SMOOTH INTERPOLANT +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C The methods in subroutine DSTEPS approximate the solution near X +C by a polynomial. Subroutine DINTP approximates the solution at +C XOUT by evaluating the polynomial there. Information defining this +C polynomial is passed from DSTEPS so DINTP cannot be used alone. +C +C Subroutine DSTEPS is completely explained and documented in the text +C "Computer Solution of Ordinary Differential Equations, the Initial +C Value Problem" by L. F. Shampine and M. K. Gordon. +C +C Input to DINTP -- +C +C The user provides storage in the calling program for the arrays in +C the call list +C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),OY(NEQN) +C AND ALPHA(12),OG(13),OW(12),GI(11),IV(10) +C and defines +C XOUT -- point at which solution is desired. +C The remaining parameters are defined in DSTEPS and passed to +C DINTP from that subroutine +C +C Output from DINTP -- +C +C YOUT(*) -- solution at XOUT +C YPOUT(*) -- derivative of solution at XOUT +C The remaining parameters are returned unaltered from their input +C values. Integration with DSTEPS may be continued. +C +C***REFERENCES H. A. Watts, A smoother interpolant for DE/STEP, INTRP +C II, Report SAND84-0293, Sandia Laboratories, 1984. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 840201 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DINTP +C + INTEGER I, IQ, IV, IVC, IW, J, JQ, KGI, KOLD, KP1, KP2, + 1 L, M, NEQN + DOUBLE PRECISION ALP, ALPHA, C, G, GDI, GDIF, GI, GAMMA, H, HI, + 1 HMU, OG, OW, OX, OY, PHI, RMU, SIGMA, TEMP1, TEMP2, TEMP3, + 2 W, X, XI, XIM1, XIQ, XOUT, Y, YOUT, YPOUT +C + DIMENSION Y(*),YOUT(*),YPOUT(*),PHI(NEQN,16),OY(*) + DIMENSION G(13),C(13),W(13),OG(13),OW(12),ALPHA(12),GI(11),IV(10) +C +C***FIRST EXECUTABLE STATEMENT DINTP + KP1 = KOLD + 1 + KP2 = KOLD + 2 +C + HI = XOUT - OX + H = X - OX + XI = HI/H + XIM1 = XI - 1.D0 +C +C INITIALIZE W(*) FOR COMPUTING G(*) +C + XIQ = XI + DO 10 IQ = 1,KP1 + XIQ = XI*XIQ + TEMP1 = IQ*(IQ+1) + 10 W(IQ) = XIQ/TEMP1 +C +C COMPUTE THE DOUBLE INTEGRAL TERM GDI +C + IF (KOLD .LE. KGI) GO TO 50 + IF (IVC .GT. 0) GO TO 20 + GDI = 1.0D0/TEMP1 + M = 2 + GO TO 30 + 20 IW = IV(IVC) + GDI = OW(IW) + M = KOLD - IW + 3 + 30 IF (M .GT. KOLD) GO TO 60 + DO 40 I = M,KOLD + 40 GDI = OW(KP2-I) - ALPHA(I)*GDI + GO TO 60 + 50 GDI = GI(KOLD) +C +C COMPUTE G(*) AND C(*) +C + 60 G(1) = XI + G(2) = 0.5D0*XI*XI + C(1) = 1.0D0 + C(2) = XI + IF (KOLD .LT. 2) GO TO 90 + DO 80 I = 2,KOLD + ALP = ALPHA(I) + GAMMA = 1.0D0 + XIM1*ALP + L = KP2 - I + DO 70 JQ = 1,L + 70 W(JQ) = GAMMA*W(JQ) - ALP*W(JQ+1) + G(I+1) = W(1) + 80 C(I+1) = GAMMA*C(I) +C +C DEFINE INTERPOLATION PARAMETERS +C + 90 SIGMA = (W(2) - XIM1*W(1))/GDI + RMU = XIM1*C(KP1)/GDI + HMU = RMU/H +C +C INTERPOLATE FOR THE SOLUTION -- YOUT +C AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT +C + DO 100 L = 1,NEQN + YOUT(L) = 0.0D0 + 100 YPOUT(L) = 0.0D0 + DO 120 J = 1,KOLD + I = KP2 - J + GDIF = OG(I) - OG(I-1) + TEMP2 = (G(I) - G(I-1)) - SIGMA*GDIF + TEMP3 = (C(I) - C(I-1)) + RMU*GDIF + DO 110 L = 1,NEQN + YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) + 110 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) + 120 CONTINUE + DO 130 L = 1,NEQN + YOUT(L) = ((1.0D0 - SIGMA)*OY(L) + SIGMA*Y(L)) + + 1 H*(YOUT(L) + (G(1) - SIGMA*OG(1))*PHI(L,1)) + 130 YPOUT(L) = HMU*(OY(L) - Y(L)) + + 1 (YPOUT(L) + (C(1) + RMU*OG(1))*PHI(L,1)) +C + RETURN + END diff --git a/SLATEC/src/dintrv.f b/SLATEC/src/dintrv.f new file mode 100644 index 0000000..960b591 --- /dev/null +++ b/SLATEC/src/dintrv.f @@ -0,0 +1,118 @@ +*DECK DINTRV + SUBROUTINE DINTRV (XT, LXT, X, ILO, ILEFT, MFLAG) +C***BEGIN PROLOGUE DINTRV +C***PURPOSE Compute the largest integer ILEFT in 1 .LE. ILEFT .LE. LXT +C such that XT(ILEFT) .LE. X where XT(*) is a subdivision of +C the X interval. +C***LIBRARY SLATEC +C***CATEGORY E3, K6 +C***TYPE DOUBLE PRECISION (INTRV-S, DINTRV-D) +C***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Written by Carl de Boor and modified by D. E. Amos +C +C Abstract **** a double precision routine **** +C DINTRV is the INTERV routine of the reference. +C +C DINTRV computes the largest integer ILEFT in 1 .LE. ILEFT .LE. +C LXT such that XT(ILEFT) .LE. X where XT(*) is a subdivision of +C the X interval. Precisely, +C +C X .LT. XT(1) 1 -1 +C if XT(I) .LE. X .LT. XT(I+1) then ILEFT=I , MFLAG=0 +C XT(LXT) .LE. X LXT 1, +C +C That is, when multiplicities are present in the break point +C to the left of X, the largest index is taken for ILEFT. +C +C Description of Arguments +C +C Input XT,X are double precision +C XT - XT is a knot or break point vector of length LXT +C LXT - length of the XT vector +C X - argument +C ILO - an initialization parameter which must be set +C to 1 the first time the spline array XT is +C processed by DINTRV. +C +C Output +C ILO - ILO contains information for efficient process- +C ing after the initial call and ILO must not be +C changed by the user. Distinct splines require +C distinct ILO parameters. +C ILEFT - largest integer satisfying XT(ILEFT) .LE. X +C MFLAG - signals when X lies out of bounds +C +C Error Conditions +C None +C +C***REFERENCES Carl de Boor, Package for calculating with B-splines, +C SIAM Journal on Numerical Analysis 14, 3 (June 1977), +C pp. 441-472. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 800901 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DINTRV +C + INTEGER IHI, ILEFT, ILO, ISTEP, LXT, MFLAG, MIDDLE + DOUBLE PRECISION X, XT + DIMENSION XT(*) +C***FIRST EXECUTABLE STATEMENT DINTRV + IHI = ILO + 1 + IF (IHI.LT.LXT) GO TO 10 + IF (X.GE.XT(LXT)) GO TO 110 + IF (LXT.LE.1) GO TO 90 + ILO = LXT - 1 + IHI = LXT +C + 10 IF (X.GE.XT(IHI)) GO TO 40 + IF (X.GE.XT(ILO)) GO TO 100 +C +C *** NOW X .LT. XT(IHI) . FIND LOWER BOUND + ISTEP = 1 + 20 IHI = ILO + ILO = IHI - ISTEP + IF (ILO.LE.1) GO TO 30 + IF (X.GE.XT(ILO)) GO TO 70 + ISTEP = ISTEP*2 + GO TO 20 + 30 ILO = 1 + IF (X.LT.XT(1)) GO TO 90 + GO TO 70 +C *** NOW X .GE. XT(ILO) . FIND UPPER BOUND + 40 ISTEP = 1 + 50 ILO = IHI + IHI = ILO + ISTEP + IF (IHI.GE.LXT) GO TO 60 + IF (X.LT.XT(IHI)) GO TO 70 + ISTEP = ISTEP*2 + GO TO 50 + 60 IF (X.GE.XT(LXT)) GO TO 110 + IHI = LXT +C +C *** NOW XT(ILO) .LE. X .LT. XT(IHI) . NARROW THE INTERVAL + 70 MIDDLE = (ILO+IHI)/2 + IF (MIDDLE.EQ.ILO) GO TO 100 +C NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1 + IF (X.LT.XT(MIDDLE)) GO TO 80 + ILO = MIDDLE + GO TO 70 + 80 IHI = MIDDLE + GO TO 70 +C *** SET OUTPUT AND RETURN + 90 MFLAG = -1 + ILEFT = 1 + RETURN + 100 MFLAG = 0 + ILEFT = ILO + RETURN + 110 MFLAG = 1 + ILEFT = LXT + RETURN + END diff --git a/SLATEC/src/drf.f b/SLATEC/src/drf.f new file mode 100644 index 0000000..e513620 --- /dev/null +++ b/SLATEC/src/drf.f @@ -0,0 +1,340 @@ +*DECK DRF + DOUBLE PRECISION FUNCTION DRF (X, Y, Z, IER) +C***BEGIN PROLOGUE DRF +C***PURPOSE Compute the incomplete or complete elliptic integral of the +C 1st kind. For X, Y, and Z non-negative and at most one of +C them zero, RF(X,Y,Z) = Integral from zero to infinity of +C -1/2 -1/2 -1/2 +C (1/2)(t+X) (t+Y) (t+Z) dt. +C If X, Y or Z is zero, the integral is complete. +C***LIBRARY SLATEC +C***CATEGORY C14 +C***TYPE DOUBLE PRECISION (RF-S, DRF-D) +C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, +C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND, +C TAYLOR SERIES +C***AUTHOR Carlson, B. C. +C Ames Laboratory-DOE +C Iowa State University +C Ames, IA 50011 +C Notis, E. M. +C Ames Laboratory-DOE +C Iowa State University +C Ames, IA 50011 +C Pexton, R. L. +C Lawrence Livermore National Laboratory +C Livermore, CA 94550 +C***DESCRIPTION +C +C 1. DRF +C Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL +C of the first kind +C Standard FORTRAN function routine +C Double precision version +C The routine calculates an approximation result to +C DRF(X,Y,Z) = Integral from zero to infinity of +C +C -1/2 -1/2 -1/2 +C (1/2)(t+X) (t+Y) (t+Z) dt, +C +C where X, Y, and Z are nonnegative and at most one of them +C is zero. If one of them is zero, the integral is COMPLETE. +C The duplication theorem is iterated until the variables are +C nearly equal, and the function is then expanded in Taylor +C series to fifth order. +C +C 2. Calling sequence +C DRF( X, Y, Z, IER ) +C +C Parameters On entry +C Values assigned by the calling routine +C +C X - Double precision, nonnegative variable +C +C Y - Double precision, nonnegative variable +C +C Z - Double precision, nonnegative variable +C +C +C +C On Return (values assigned by the DRF routine) +C +C DRF - Double precision approximation to the integral +C +C IER - Integer +C +C IER = 0 Normal and reliable termination of the +C routine. It is assumed that the requested +C accuracy has been achieved. +C +C IER > 0 Abnormal termination of the routine +C +C X, Y, Z are unaltered. +C +C +C 3. Error Messages +C +C +C Value of IER assigned by the DRF routine +C +C Value assigned Error Message Printed +C IER = 1 MIN(X,Y,Z) .LT. 0.0D0 +C = 2 MIN(X+Y,X+Z,Y+Z) .LT. LOLIM +C = 3 MAX(X,Y,Z) .GT. UPLIM +C +C +C +C 4. Control Parameters +C +C Values of LOLIM, UPLIM, and ERRTOL are set by the +C routine. +C +C LOLIM and UPLIM determine the valid range of X, Y and Z +C +C LOLIM - Lower limit of valid arguments +C +C Not less than 5 * (machine minimum). +C +C UPLIM - Upper limit of valid arguments +C +C Not greater than (machine maximum) / 5. +C +C +C Acceptable values for: LOLIM UPLIM +C IBM 360/370 SERIES : 3.0D-78 1.0D+75 +C CDC 6000/7000 SERIES : 1.0D-292 1.0D+321 +C UNIVAC 1100 SERIES : 1.0D-307 1.0D+307 +C CRAY : 2.3D-2466 1.09D+2465 +C VAX 11 SERIES : 1.5D-38 3.0D+37 +C +C +C +C ERRTOL determines the accuracy of the answer +C +C The value assigned by the routine will result +C in solution precision within 1-2 decimals of +C "machine precision". +C +C +C +C ERRTOL - Relative error due to truncation is less than +C ERRTOL ** 6 / (4 * (1-ERRTOL) . +C +C +C +C The accuracy of the computed approximation to the integral +C can be controlled by choosing the value of ERRTOL. +C Truncation of a Taylor series after terms of fifth order +C introduces an error less than the amount shown in the +C second column of the following table for each value of +C ERRTOL in the first column. In addition to the truncation +C error there will be round-off error, but in practice the +C total error from both sources is usually less than the +C amount given in the table. +C +C +C +C +C +C Sample choices: ERRTOL Relative Truncation +C error less than +C 1.0D-3 3.0D-19 +C 3.0D-3 2.0D-16 +C 1.0D-2 3.0D-13 +C 3.0D-2 2.0D-10 +C 1.0D-1 3.0D-7 +C +C +C Decreasing ERRTOL by a factor of 10 yields six more +C decimal digits of accuracy at the expense of one or +C two more iterations of the duplication theorem. +C +C *Long Description: +C +C DRF Special Comments +C +C +C +C Check by addition theorem: DRF(X,X+Z,X+W) + DRF(Y,Y+Z,Y+W) +C = DRF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W. +C +C +C On Input: +C +C X, Y, and Z are the variables in the integral DRF(X,Y,Z). +C +C +C On Output: +C +C +C X, Y, Z are unaltered. +C +C +C +C ******************************************************** +C +C WARNING: Changes in the program may improve speed at the +C expense of robustness. +C +C +C +C Special double precision functions via DRF +C +C +C +C +C Legendre form of ELLIPTIC INTEGRAL of 1st kind +C +C ----------------------------------------- +C +C +C +C 2 2 2 +C F(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1) +C +C +C 2 +C K(K) = DRF(0,1-K ,1) +C +C +C PI/2 2 2 -1/2 +C = INT (1-K SIN (PHI) ) D PHI +C 0 +C +C +C +C Bulirsch form of ELLIPTIC INTEGRAL of 1st kind +C +C ----------------------------------------- +C +C +C 2 2 2 +C EL1(X,KC) = X DRF(1,1+KC X ,1+X ) +C +C +C Lemniscate constant A +C +C ----------------------------------------- +C +C +C 1 4 -1/2 +C A = INT (1-S ) DS = DRF(0,1,2) = DRF(0,2,1) +C 0 +C +C +C +C ------------------------------------------------------------------- +C +C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete +C elliptic integrals, ACM Transactions on Mathematical +C Software 7, 3 (September 1981), pp. 398-403. +C B. C. Carlson, Computing elliptic integrals by +C duplication, Numerische Mathematik 33, (1979), +C pp. 1-16. +C B. C. Carlson, Elliptic integrals of the first kind, +C SIAM Journal of Mathematical Analysis 8, (1977), +C pp. 231-242. +C***ROUTINES CALLED D1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891009 Removed unreferenced statement labels. (WRB) +C 891009 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900510 Changed calls to XERMSG to standard form, and some +C editorial changes. (RWC)) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DRF + CHARACTER*16 XERN3, XERN4, XERN5, XERN6 + INTEGER IER + DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH + DOUBLE PRECISION C1, C2, C3, E2, E3, LAMDA + DOUBLE PRECISION MU, S, X, XN, XNDEV + DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, + * ZNROOT + LOGICAL FIRST + SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST + DATA FIRST /.TRUE./ +C +C***FIRST EXECUTABLE STATEMENT DRF +C + IF (FIRST) THEN + ERRTOL = (4.0D0*D1MACH(3))**(1.0D0/6.0D0) + LOLIM = 5.0D0 * D1MACH(1) + UPLIM = D1MACH(2)/5.0D0 +C + C1 = 1.0D0/24.0D0 + C2 = 3.0D0/44.0D0 + C3 = 1.0D0/14.0D0 + ENDIF + FIRST = .FALSE. +C +C CALL ERROR HANDLER IF NECESSARY. +C + DRF = 0.0D0 + IF (MIN(X,Y,Z).LT.0.0D0) THEN + IER = 1 + WRITE (XERN3, '(1PE15.6)') X + WRITE (XERN4, '(1PE15.6)') Y + WRITE (XERN5, '(1PE15.6)') Z + CALL XERMSG ('SLATEC', 'DRF', + * 'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 // + * ' AND Z = ' // XERN5, 1, 1) + RETURN + ENDIF +C + IF (MAX(X,Y,Z).GT.UPLIM) THEN + IER = 3 + WRITE (XERN3, '(1PE15.6)') X + WRITE (XERN4, '(1PE15.6)') Y + WRITE (XERN5, '(1PE15.6)') Z + WRITE (XERN6, '(1PE15.6)') UPLIM + CALL XERMSG ('SLATEC', 'DRF', + * 'MAX(X,Y,Z).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' // + * XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, 3, 1) + RETURN + ENDIF +C + IF (MIN(X+Y,X+Z,Y+Z).LT.LOLIM) THEN + IER = 2 + WRITE (XERN3, '(1PE15.6)') X + WRITE (XERN4, '(1PE15.6)') Y + WRITE (XERN5, '(1PE15.6)') Z + WRITE (XERN6, '(1PE15.6)') LOLIM + CALL XERMSG ('SLATEC', 'DRF', + * 'MIN(X+Y,X+Z,Y+Z).LT.LOLIM WHERE X = ' // XERN3 // + * ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // + * XERN6, 2, 1) + RETURN + ENDIF +C + IER = 0 + XN = X + YN = Y + ZN = Z +C + 30 MU = (XN+YN+ZN)/3.0D0 + XNDEV = 2.0D0 - (MU+XN)/MU + YNDEV = 2.0D0 - (MU+YN)/MU + ZNDEV = 2.0D0 - (MU+ZN)/MU + EPSLON = MAX(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV)) + IF (EPSLON.LT.ERRTOL) GO TO 40 + XNROOT = SQRT(XN) + YNROOT = SQRT(YN) + ZNROOT = SQRT(ZN) + LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT + XN = (XN+LAMDA)*0.250D0 + YN = (YN+LAMDA)*0.250D0 + ZN = (ZN+LAMDA)*0.250D0 + GO TO 30 +C + 40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV + E3 = XNDEV*YNDEV*ZNDEV + S = 1.0D0 + (C1*E2-0.10D0-C2*E3)*E2 + C3*E3 + DRF = S/SQRT(MU) +C + RETURN + END diff --git a/SLATEC/src/drkfs.f b/SLATEC/src/drkfs.f new file mode 100644 index 0000000..c3288c6 --- /dev/null +++ b/SLATEC/src/drkfs.f @@ -0,0 +1,726 @@ +*DECK DRKFS + SUBROUTINE DRKFS (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, H, + + TOLFAC, YP, F1, F2, F3, F4, F5, YS, TOLD, DTSIGN, U26, RER, + + INIT, KSTEPS, KOP, IQUIT, STIFF, NONSTF, NTSTEP, NSTIFS, RPAR, + + IPAR) +C***BEGIN PROLOGUE DRKFS +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (DERKFS-S, DRKFS-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C Fehlberg Fourth-Fifth Order Runge-Kutta Method +C ********************************************************************** +C +C DRKFS integrates a system of first order ordinary differential +C equations as described in the comments for DDERKF . +C +C The arrays YP,F1,F2,F3,F4,F5,and YS (of length at least NEQ) +C appear in the call list for variable dimensioning purposes. +C +C The variables H,TOLFAC,TOLD,DTSIGN,U26,RER,INIT,KSTEPS,KOP,IQUIT, +C STIFF,NONSTF,NTSTEP, and NSTIFS are used internally by the code +C and appear in the call list to eliminate local retention of +C variables between calls. Accordingly, these variables and the +C array YP should not be altered. +C Items of possible interest are +C H - An appropriate step size to be used for the next step +C TOLFAC - Factor of change in the tolerances +C YP - Derivative of solution vector at T +C KSTEPS - Counter on the number of steps attempted +C +C ********************************************************************** +C +C***SEE ALSO DDERKF +C***ROUTINES CALLED D1MACH, DFEHL, DHSTRT, DHVNRM, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900510 Convert XERRWV calls to XERMSG calls, change GOTOs to +C IF-THEN-ELSEs. (RWC) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DRKFS +C + INTEGER IDID, INFO, INIT, IPAR, IQUIT, K, KOP, KSTEPS, KTOL, + 1 MXKOP, MXSTEP, NATOLP, NEQ, NRTOLP, NSTIFS, NTSTEP + DOUBLE PRECISION A, ATOL, BIG, D1MACH, + 1 DT, DTSIGN, DHVNRM, DY, EE, EEOET, ES, ESTIFF, + 2 ESTTOL, ET, F1, F2, F3, F4, F5, H, HMIN, REMIN, RER, RPAR, + 3 RTOL, S, T, TOL, TOLD, TOLFAC, TOUT, U, U26, UTE, Y, YAVG, + 4 YP, YS + LOGICAL HFAILD,OUTPUT,STIFF,NONSTF + CHARACTER*8 XERN1 + CHARACTER*16 XERN3, XERN4 +C + DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), + 1 YS(*),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) +C + EXTERNAL DF +C +C .................................................................. +C +C A FIFTH ORDER METHOD WILL GENERALLY NOT BE CAPABLE OF DELIVERING +C ACCURACIES NEAR LIMITING PRECISION ON COMPUTERS WITH LONG +C WORDLENGTHS. TO PROTECT AGAINST LIMITING PRECISION DIFFICULTIES +C ARISING FROM UNREASONABLE ACCURACY REQUESTS, AN APPROPRIATE +C TOLERANCE THRESHOLD REMIN IS ASSIGNED FOR THIS METHOD. THIS +C VALUE SHOULD NOT BE CHANGED ACROSS DIFFERENT MACHINES. +C + SAVE REMIN, MXSTEP, MXKOP + DATA REMIN /1.0D-12/ +C +C .................................................................. +C +C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE +C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MXSTEP, THE +C COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE +C EXCESSIVE WORK. +C + DATA MXSTEP /500/ +C +C .................................................................. +C +C INEFFICIENCY CAUSED BY TOO FREQUENT OUTPUT IS MONITORED BY +C COUNTING THE NUMBER OF STEP SIZES WHICH ARE SEVERELY SHORTENED +C DUE SOLELY TO THE CHOICE OF OUTPUT POINTS. WHEN THE NUMBER OF +C ABUSES EXCEED MXKOP, THE COUNTER IS RESET TO ZERO AND THE USER +C IS INFORMED ABOUT POSSIBLE MISUSE OF THE CODE. +C + DATA MXKOP /100/ +C +C .................................................................. +C +C***FIRST EXECUTABLE STATEMENT DRKFS + IF (INFO(1) .EQ. 0) THEN +C +C ON THE FIRST CALL , PERFORM INITIALIZATION -- +C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE +C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE +C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. +C + U = D1MACH(4) +C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS + U26 = 26.0D0*U + RER = 2.0D0*U + REMIN +C -- SET TERMINATION FLAG + IQUIT = 0 +C -- SET INITIALIZATION INDICATOR + INIT = 0 +C -- SET COUNTER FOR IMPACT OF OUTPUT POINTS + KOP = 0 +C -- SET COUNTER FOR ATTEMPTED STEPS + KSTEPS = 0 +C -- SET INDICATORS FOR STIFFNESS DETECTION + STIFF = .FALSE. + NONSTF = .FALSE. +C -- SET STEP COUNTERS FOR STIFFNESS DETECTION + NTSTEP = 0 + NSTIFS = 0 +C -- RESET INFO(1) FOR SUBSEQUENT CALLS + INFO(1) = 1 + ENDIF +C +C....................................................................... +C +C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY +C + IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(1) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, INFO(1) MUST BE SET TO 0 ' // + * 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // + * 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // + * 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE CODE ' // + * 'WITH INFO(1) = ' // XERN1, 3, 1) + IDID = -33 + ENDIF +C + IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(2) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, INFO(2) MUST BE 0 OR 1 ' // + * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // + * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // + * XERN1, 4, 1) + IDID = -33 + ENDIF +C + IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(3) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, INFO(3) MUST BE 0 OR 1 ' // + * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // + * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // + * 'WITH INFO(3) = ' // XERN1, 5, 1) + IDID = -33 + ENDIF +C + IF (NEQ .LT. 1) THEN + WRITE (XERN1, '(I8)') NEQ + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, THE NUMBER OF EQUATIONS ' // + * 'NEQ MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // + * 'CODE WITH NEQ = ' // XERN1, 6, 1) + IDID = -33 + ENDIF +C + NRTOLP = 0 + NATOLP = 0 + DO 10 K=1,NEQ + IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') RTOL(K) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, THE RELATIVE ERROR ' // + * 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // + * 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // + * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // + * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) + IDID = -33 + NRTOLP = 1 + ENDIF +C + IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') ATOL(K) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, THE ABSOLUTE ERROR ' // + * 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // + * 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // + * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // + * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) + IDID = -33 + NATOLP = 1 + ENDIF +C + IF (INFO(2) .EQ. 0) GO TO 20 + IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 20 + 10 CONTINUE +C +C +C CHECK SOME CONTINUATION POSSIBILITIES +C + 20 IF (INIT .NE. 0) THEN + IF (T .EQ. TOUT) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, YOU HAVE CALLED THE ' // + * 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // + * 'ALLOWED ON CONTINUATION CALLS.', 9, 1) + IDID=-33 + ENDIF +C + IF (T .NE. TOLD) THEN + WRITE (XERN3, '(1PE15.6)') TOLD + WRITE (XERN4, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, YOU HAVE CHANGED THE ' // + * 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // + * '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) + IDID=-33 + ENDIF +C + IF (INIT .NE. 1) THEN + IF (DTSIGN*(TOUT-T) .LT. 0.D0) THEN + WRITE (XERN3, '(1PE15.6)') TOUT + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, BY CALLING THE CODE WITH TOUT = ' // + * XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // + * 'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' // + * 'WITHOUT RESTARTING.', 11, 1) + IDID=-33 + ENDIF + ENDIF + ENDIF +C +C INVALID INPUT DETECTED +C + IF (IDID .EQ. (-33)) THEN + IF (IQUIT .NE. (-33)) THEN + IQUIT = -33 + GOTO 540 + ELSE + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, INVALID INPUT WAS ' // + * 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // + * 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // + * 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) + RETURN + ENDIF + ENDIF +C +C ............................................................ +C +C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND +C INTERPRETED AS ASKING FOR THE MOST ACCURATE SOLUTION +C POSSIBLE. IN THIS CASE, THE RELATIVE ERROR TOLERANCE +C RTOL IS RESET TO THE SMALLEST VALUE RER WHICH IS LIKELY +C TO BE REASONABLE FOR THIS METHOD AND MACHINE. +C + DO 190 K = 1, NEQ + IF (RTOL(K) + ATOL(K) .GT. 0.0D0) GO TO 180 + RTOL(K) = RER + IDID = -2 + 180 CONTINUE +C ...EXIT + IF (INFO(2) .EQ. 0) GO TO 200 + 190 CONTINUE + 200 CONTINUE +C + IF (IDID .NE. (-2)) GO TO 210 +C +C RTOL=ATOL=0 ON INPUT, SO RTOL WAS CHANGED TO A +C SMALL POSITIVE VALUE + TOLFAC = 1.0D0 + GO TO 530 + 210 CONTINUE +C +C BRANCH ON STATUS OF INITIALIZATION INDICATOR +C INIT=0 MEANS INITIAL DERIVATIVES AND +C STARTING STEP SIZE +C NOT YET COMPUTED +C INIT=1 MEANS STARTING STEP SIZE NOT YET +C COMPUTED INIT=2 MEANS NO FURTHER +C INITIALIZATION REQUIRED +C + IF (INIT .EQ. 0) GO TO 220 +C ......EXIT + IF (INIT .EQ. 1) GO TO 240 +C .........EXIT + GO TO 260 + 220 CONTINUE +C +C ................................................ +C +C MORE INITIALIZATION -- +C -- EVALUATE INITIAL +C DERIVATIVES +C + INIT = 1 + A = T + CALL DF(A,Y,YP,RPAR,IPAR) + IF (T .NE. TOUT) GO TO 230 +C +C INTERVAL MODE + IDID = 2 + T = TOUT + TOLD = T +C .....................EXIT + GO TO 560 + 230 CONTINUE + 240 CONTINUE +C +C -- SET SIGN OF INTEGRATION DIRECTION AND +C -- ESTIMATE STARTING STEP SIZE +C + INIT = 2 + DTSIGN = SIGN(1.0D0,TOUT-T) + U = D1MACH(4) + BIG = SQRT(D1MACH(2)) + UTE = U**0.375D0 + DY = UTE*DHVNRM(Y,NEQ) + IF (DY .EQ. 0.0D0) DY = UTE + KTOL = 1 + DO 250 K = 1, NEQ + IF (INFO(2) .EQ. 1) KTOL = K + TOL = RTOL(KTOL)*ABS(Y(K)) + ATOL(KTOL) + IF (TOL .EQ. 0.0D0) TOL = DY*RTOL(KTOL) + F1(K) = TOL + 250 CONTINUE +C + CALL DHSTRT(DF,NEQ,T,TOUT,Y,YP,F1,4,U,BIG,F2,F3,F4, + 1 F5,RPAR,IPAR,H) + 260 CONTINUE +C +C ...................................................... +C +C SET STEP SIZE FOR INTEGRATION IN THE DIRECTION +C FROM T TO TOUT AND SET OUTPUT POINT INDICATOR +C + DT = TOUT - T + H = SIGN(H,DT) + OUTPUT = .FALSE. +C +C TEST TO SEE IF DDERKF IS BEING SEVERELY IMPACTED BY +C TOO MANY OUTPUT POINTS +C + IF (ABS(H) .GE. 2.0D0*ABS(DT)) KOP = KOP + 1 + IF (KOP .LE. MXKOP) GO TO 270 +C +C UNNECESSARY FREQUENCY OF OUTPUT IS RESTRICTING +C THE STEP SIZE CHOICE + IDID = -5 + KOP = 0 + GO TO 510 + 270 CONTINUE +C + IF (ABS(DT) .GT. U26*ABS(T)) GO TO 290 +C +C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND +C RETURN +C + DO 280 K = 1, NEQ + Y(K) = Y(K) + DT*YP(K) + 280 CONTINUE + A = TOUT + CALL DF(A,Y,YP,RPAR,IPAR) + KSTEPS = KSTEPS + 1 + GO TO 500 + 290 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 490 +C +C ********************************************* +C ********************************************* +C STEP BY STEP INTEGRATION +C + 300 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 480 + HFAILD = .FALSE. +C +C TO PROTECT AGAINST IMPOSSIBLE ACCURACY +C REQUESTS, COMPUTE A TOLERANCE FACTOR +C BASED ON THE REQUESTED ERROR TOLERANCE +C AND A LEVEL OF ACCURACY ACHIEVABLE AT +C LIMITING PRECISION +C + TOLFAC = 0.0D0 + KTOL = 1 + DO 330 K = 1, NEQ + IF (INFO(2) .EQ. 1) KTOL = K + ET = RTOL(KTOL)*ABS(Y(K)) + 1 + ATOL(KTOL) + IF (ET .GT. 0.0D0) GO TO 310 + TOLFAC = MAX(TOLFAC, + 1 RER/RTOL(KTOL)) + GO TO 320 + 310 CONTINUE + TOLFAC = MAX(TOLFAC, + 1 ABS(Y(K)) + 2 *(RER/ET)) + 320 CONTINUE + 330 CONTINUE + IF (TOLFAC .LE. 1.0D0) GO TO 340 +C +C REQUESTED ERROR UNATTAINABLE DUE TO LIMITED +C PRECISION AVAILABLE + TOLFAC = 2.0D0*TOLFAC + IDID = -2 +C .....................EXIT + GO TO 520 + 340 CONTINUE +C +C SET SMALLEST ALLOWABLE STEP SIZE +C + HMIN = U26*ABS(T) +C +C ADJUST STEP SIZE IF NECESSARY TO HIT +C THE OUTPUT POINT -- LOOK AHEAD TWO +C STEPS TO AVOID DRASTIC CHANGES IN THE +C STEP SIZE AND THUS LESSEN THE IMPACT OF +C OUTPUT POINTS ON THE CODE. STRETCH THE +C STEP SIZE BY, AT MOST, AN AMOUNT EQUAL +C TO THE SAFETY FACTOR OF 9/10. +C + DT = TOUT - T + IF (ABS(DT) .GE. 2.0D0*ABS(H)) + 1 GO TO 370 + IF (ABS(DT) .GT. ABS(H)/0.9D0) + 1 GO TO 350 +C +C THE NEXT STEP, IF SUCCESSFUL, +C WILL COMPLETE THE INTEGRATION TO +C THE OUTPUT POINT +C + OUTPUT = .TRUE. + H = DT + GO TO 360 + 350 CONTINUE +C + H = 0.5D0*DT + 360 CONTINUE + 370 CONTINUE +C +C +C *************************************** +C CORE INTEGRATOR FOR TAKING A +C SINGLE STEP +C *************************************** +C TO AVOID PROBLEMS WITH ZERO +C CROSSINGS, RELATIVE ERROR IS +C MEASURED USING THE AVERAGE OF THE +C MAGNITUDES OF THE SOLUTION AT THE +C BEGINNING AND END OF A STEP. +C THE ERROR ESTIMATE FORMULA HAS +C BEEN GROUPED TO CONTROL LOSS OF +C SIGNIFICANCE. +C LOCAL ERROR ESTIMATES FOR A FIRST +C ORDER METHOD USING THE SAME +C STEP SIZE AS THE FEHLBERG METHOD +C ARE CALCULATED AS PART OF THE +C TEST FOR STIFFNESS. +C TO DISTINGUISH THE VARIOUS +C ARGUMENTS, H IS NOT PERMITTED +C TO BECOME SMALLER THAN 26 UNITS OF +C ROUNDOFF IN T. PRACTICAL LIMITS +C ON THE CHANGE IN THE STEP SIZE ARE +C ENFORCED TO SMOOTH THE STEP SIZE +C SELECTION PROCESS AND TO AVOID +C EXCESSIVE CHATTERING ON PROBLEMS +C HAVING DISCONTINUITIES. TO +C PREVENT UNNECESSARY FAILURES, THE +C CODE USES 9/10 THE STEP SIZE +C IT ESTIMATES WILL SUCCEED. +C AFTER A STEP FAILURE, THE STEP +C SIZE IS NOT ALLOWED TO INCREASE +C FOR THE NEXT ATTEMPTED STEP. THIS +C MAKES THE CODE MORE EFFICIENT ON +C PROBLEMS HAVING DISCONTINUITIES +C AND MORE EFFECTIVE IN GENERAL +C SINCE LOCAL EXTRAPOLATION IS BEING +C USED AND EXTRA CAUTION SEEMS +C WARRANTED. +C ....................................... +C +C MONITOR NUMBER OF STEPS ATTEMPTED +C + 380 CONTINUE + IF (KSTEPS .LE. MXSTEP) GO TO 390 +C +C A SIGNIFICANT AMOUNT OF WORK HAS +C BEEN EXPENDED + IDID = -1 + KSTEPS = 0 +C ........................EXIT + IF (.NOT.STIFF) GO TO 520 +C +C PROBLEM APPEARS TO BE STIFF + IDID = -4 + STIFF = .FALSE. + NONSTF = .FALSE. + NTSTEP = 0 + NSTIFS = 0 +C ........................EXIT + GO TO 520 + 390 CONTINUE +C +C ADVANCE AN APPROXIMATE SOLUTION OVER +C ONE STEP OF LENGTH H +C + CALL DFEHL(DF,NEQ,T,Y,H,YP,F1,F2,F3, + 1 F4,F5,YS,RPAR,IPAR) + KSTEPS = KSTEPS + 1 +C +C .................................... +C +C COMPUTE AND TEST ALLOWABLE +C TOLERANCES VERSUS LOCAL ERROR +C ESTIMATES. NOTE THAT RELATIVE +C ERROR IS MEASURED WITH RESPECT +C TO THE AVERAGE OF THE +C MAGNITUDES OF THE SOLUTION AT +C THE BEGINNING AND END OF THE +C STEP. LOCAL ERROR ESTIMATES +C FOR A SPECIAL FIRST ORDER +C METHOD ARE CALCULATED ONLY WHEN +C THE STIFFNESS DETECTION IS +C TURNED ON. +C + EEOET = 0.0D0 + ESTIFF = 0.0D0 + KTOL = 1 + DO 420 K = 1, NEQ + YAVG = 0.5D0 + 1 *(ABS(Y(K)) + 2 + ABS(YS(K))) + IF (INFO(2) .EQ. 1) KTOL = K + ET = RTOL(KTOL)*YAVG + ATOL(KTOL) + IF (ET .GT. 0.0D0) GO TO 400 +C +C PURE RELATIVE ERROR INAPPROPRIATE WHEN SOLUTION +C VANISHES + IDID = -3 +C ...........................EXIT + GO TO 520 + 400 CONTINUE +C + EE = ABS((-2090.0D0*YP(K) + 1 +(21970.0D0*F3(K) + 2 -15048.0D0*F4(K))) + 3 +(22528.0D0*F2(K) + 4 -27360.0D0*F5(K))) + IF (STIFF .OR. NONSTF) GO TO 410 + ES = ABS(H + 1 *(0.055455D0*YP(K) + 2 -0.035493D0*F1(K) + 3 -0.036571D0*F2(K) + 4 +0.023107D0*F3(K) + 5 -0.009515D0*F4(K) + 6 +0.003017D0*F5(K)) + 7 ) + ESTIFF = MAX(ESTIFF,ES/ET) + 410 CONTINUE + EEOET = MAX(EEOET,EE/ET) + 420 CONTINUE +C + ESTTOL = ABS(H)*EEOET/752400.0D0 +C +C ...EXIT + IF (ESTTOL .LE. 1.0D0) GO TO 440 +C +C .................................... +C +C UNSUCCESSFUL STEP +C + IF (ABS(H) .GT. HMIN) GO TO 430 +C +C REQUESTED ERROR UNATTAINABLE AT SMALLEST +C ALLOWABLE STEP SIZE + TOLFAC = 1.69D0*ESTTOL + IDID = -2 +C ........................EXIT + GO TO 520 + 430 CONTINUE +C +C REDUCE THE STEP SIZE , TRY AGAIN +C THE DECREASE IS LIMITED TO A FACTOR +C OF 1/10 +C + HFAILD = .TRUE. + OUTPUT = .FALSE. + S = 0.1D0 + IF (ESTTOL .LT. 59049.0D0) + 1 S = 0.9D0/ESTTOL**0.2D0 + H = SIGN(MAX(S*ABS(H),HMIN),H) + GO TO 380 + 440 CONTINUE +C +C ....................................... +C +C SUCCESSFUL STEP +C STORE SOLUTION AT T+H +C AND EVALUATE +C DERIVATIVES THERE +C + T = T + H + DO 450 K = 1, NEQ + Y(K) = YS(K) + 450 CONTINUE + A = T + CALL DF(A,Y,YP,RPAR,IPAR) +C +C CHOOSE NEXT STEP SIZE +C THE INCREASE IS LIMITED TO A FACTOR OF +C 5 IF STEP FAILURE HAS JUST OCCURRED, +C NEXT +C STEP SIZE IS NOT ALLOWED TO INCREASE +C + S = 5.0D0 + IF (ESTTOL .GT. 1.889568D-4) + 1 S = 0.9D0/ESTTOL**0.2D0 + IF (HFAILD) S = MIN(S,1.0D0) + H = SIGN(MAX(S*ABS(H),HMIN),H) +C +C ....................................... +C +C CHECK FOR STIFFNESS (IF NOT +C ALREADY DETECTED) +C +C IN A SEQUENCE OF 50 SUCCESSFUL +C STEPS BY THE FEHLBERG METHOD, 25 +C SUCCESSFUL STEPS BY THE FIRST +C ORDER METHOD INDICATES STIFFNESS +C AND TURNS THE TEST OFF. IF 26 +C FAILURES BY THE FIRST ORDER METHOD +C OCCUR, THE TEST IS TURNED OFF +C UNTIL THIS SEQUENCE OF 50 STEPS BY +C THE FEHLBERG METHOD IS COMPLETED. +C +C ...EXIT + IF (STIFF) GO TO 480 + NTSTEP = MOD(NTSTEP+1,50) + IF (NTSTEP .EQ. 1) NONSTF = .FALSE. +C ...EXIT + IF (NONSTF) GO TO 480 + IF (ESTIFF .GT. 1.0D0) GO TO 460 +C +C SUCCESSFUL STEP WITH FIRST ORDER +C METHOD + NSTIFS = NSTIFS + 1 +C TURN TEST OFF AFTER 25 INDICATIONS +C OF STIFFNESS + IF (NSTIFS .EQ. 25) STIFF = .TRUE. + GO TO 470 + 460 CONTINUE +C +C UNSUCCESSFUL STEP WITH FIRST ORDER +C METHOD + IF (NTSTEP - NSTIFS .LE. 25) GO TO 470 +C TURN STIFFNESS DETECTION OFF FOR THIS BLOCK OF +C FIFTY STEPS + NONSTF = .TRUE. +C RESET STIFF STEP COUNTER + NSTIFS = 0 + 470 CONTINUE + 480 CONTINUE +C +C ****************************************** +C END OF CORE INTEGRATOR +C ****************************************** +C +C +C SHOULD WE TAKE ANOTHER STEP +C +C ......EXIT + IF (OUTPUT) GO TO 490 + IF (INFO(3) .EQ. 0) GO TO 300 +C +C ********************************************* +C ********************************************* +C +C INTEGRATION SUCCESSFULLY COMPLETED +C +C ONE-STEP MODE + IDID = 1 + TOLD = T +C .....................EXIT + GO TO 560 + 490 CONTINUE + 500 CONTINUE +C +C INTERVAL MODE + IDID = 2 + T = TOUT + TOLD = T +C ...............EXIT + GO TO 560 + 510 CONTINUE + 520 CONTINUE + 530 CONTINUE + 540 CONTINUE +C +C INTEGRATION TASK INTERRUPTED +C + INFO(1) = -1 + TOLD = T +C ...EXIT + IF (IDID .NE. (-2)) GO TO 560 +C +C THE ERROR TOLERANCES ARE INCREASED TO VALUES +C WHICH ARE APPROPRIATE FOR CONTINUING + RTOL(1) = TOLFAC*RTOL(1) + ATOL(1) = TOLFAC*ATOL(1) +C ...EXIT + IF (INFO(2) .EQ. 0) GO TO 560 + DO 550 K = 2, NEQ + RTOL(K) = TOLFAC*RTOL(K) + ATOL(K) = TOLFAC*ATOL(K) + 550 CONTINUE + 560 CONTINUE + RETURN + END diff --git a/SLATEC/src/dscal.f b/SLATEC/src/dscal.f new file mode 100644 index 0000000..0c204c9 --- /dev/null +++ b/SLATEC/src/dscal.f @@ -0,0 +1,80 @@ +*DECK DSCAL + SUBROUTINE DSCAL (N, DA, DX, INCX) +C***BEGIN PROLOGUE DSCAL +C***PURPOSE Multiply a vector by a constant. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A6 +C***TYPE DOUBLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C) +C***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DA double precision scale factor +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C +C --Output-- +C DX double precision result (unchanged if N.LE.0) +C +C Replace double precision DX by double precision DA*DX. +C For I = 0 to N-1, replace DX(IX+I*INCX) with DA * DX(IX+I*INCX), +C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900821 Modified to correct problem with a negative increment. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DSCAL + DOUBLE PRECISION DA, DX(*) + INTEGER I, INCX, IX, M, MP1, N +C***FIRST EXECUTABLE STATEMENT DSCAL + IF (N .LE. 0) RETURN + IF (INCX .EQ. 1) GOTO 20 +C +C Code for increment not equal to 1. +C + IX = 1 + IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 + DO 10 I = 1,N + DX(IX) = DA*DX(IX) + IX = IX + INCX + 10 CONTINUE + RETURN +C +C Code for increment equal to 1. +C +C Clean-up loop so remaining vector length is a multiple of 5. +C + 20 M = MOD(N,5) + IF (M .EQ. 0) GOTO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF (N .LT. 5) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I+1) = DA*DX(I+1) + DX(I+2) = DA*DX(I+2) + DX(I+3) = DA*DX(I+3) + DX(I+4) = DA*DX(I+4) + 50 CONTINUE + RETURN + END diff --git a/SLATEC/src/dsifa.f b/SLATEC/src/dsifa.f new file mode 100644 index 0000000..b03f250 --- /dev/null +++ b/SLATEC/src/dsifa.f @@ -0,0 +1,237 @@ +*DECK DSIFA + SUBROUTINE DSIFA (A, LDA, N, KPVT, INFO) +C***BEGIN PROLOGUE DSIFA +C***PURPOSE Factor a real symmetric matrix by elimination with +C symmetric pivoting. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2B1A +C***TYPE DOUBLE PRECISION (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C) +C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, SYMMETRIC +C***AUTHOR Bunch, J., (UCSD) +C***DESCRIPTION +C +C DSIFA factors a double precision symmetric matrix by elimination +C with symmetric pivoting. +C +C To solve A*X = B , follow DSIFA by DSISL. +C To compute INVERSE(A)*C , follow DSIFA by DSISL. +C To compute DETERMINANT(A) , follow DSIFA by DSIDI. +C To compute INERTIA(A) , follow DSIFA by DSIDI. +C To compute INVERSE(A) , follow DSIFA by DSIDI. +C +C On Entry +C +C A DOUBLE PRECISION(LDA,N) +C the symmetric matrix to be factored. +C Only the diagonal and upper triangle are used. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C On Return +C +C A a block diagonal matrix and the multipliers which +C were used to obtain it. +C The factorization can be written A = U*D*TRANS(U) +C where U is a product of permutation and unit +C upper triangular matrices, TRANS(U) is the +C transpose of U , and D is block diagonal +C with 1 by 1 and 2 by 2 blocks. +C +C KPVT INTEGER(N) +C an integer vector of pivot indices. +C +C INFO INTEGER +C = 0 normal value. +C = K if the K-th pivot block is singular. This is +C not an error condition for this subroutine, +C but it does indicate that DSISL or DSIDI may +C divide by zero if called. +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED DAXPY, DSWAP, IDAMAX +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891107 Modified routine equivalence list. (WRB) +C 891107 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DSIFA + INTEGER LDA,N,KPVT(*),INFO + DOUBLE PRECISION A(LDA,*) +C + DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T + DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX + INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX + LOGICAL SWAP +C***FIRST EXECUTABLE STATEMENT DSIFA +C +C INITIALIZE +C +C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. +C + ALPHA = (1.0D0 + SQRT(17.0D0))/8.0D0 +C + INFO = 0 +C +C MAIN LOOP ON K, WHICH GOES FROM N TO 1. +C + K = N + 10 CONTINUE +C +C LEAVE THE LOOP IF K=0 OR K=1. +C + IF (K .EQ. 0) GO TO 200 + IF (K .GT. 1) GO TO 20 + KPVT(1) = 1 + IF (A(1,1) .EQ. 0.0D0) INFO = 1 + GO TO 200 + 20 CONTINUE +C +C THIS SECTION OF CODE DETERMINES THE KIND OF +C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, +C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND +C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS +C REQUIRED. +C + KM1 = K - 1 + ABSAKK = ABS(A(K,K)) +C +C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN +C COLUMN K. +C + IMAX = IDAMAX(K-1,A(1,K),1) + COLMAX = ABS(A(IMAX,K)) + IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 + KSTEP = 1 + SWAP = .FALSE. + GO TO 90 + 30 CONTINUE +C +C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN +C ROW IMAX. +C + ROWMAX = 0.0D0 + IMAXP1 = IMAX + 1 + DO 40 J = IMAXP1, K + ROWMAX = MAX(ROWMAX,ABS(A(IMAX,J))) + 40 CONTINUE + IF (IMAX .EQ. 1) GO TO 50 + JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) + ROWMAX = MAX(ROWMAX,ABS(A(JMAX,IMAX))) + 50 CONTINUE + IF (ABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 + KSTEP = 1 + SWAP = .TRUE. + GO TO 80 + 60 CONTINUE + IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 + KSTEP = 1 + SWAP = .FALSE. + GO TO 80 + 70 CONTINUE + KSTEP = 2 + SWAP = IMAX .NE. KM1 + 80 CONTINUE + 90 CONTINUE + IF (MAX(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 +C +C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. +C + KPVT(K) = K + INFO = K + GO TO 190 + 100 CONTINUE + IF (KSTEP .EQ. 2) GO TO 140 +C +C 1 X 1 PIVOT BLOCK. +C + IF (.NOT.SWAP) GO TO 120 +C +C PERFORM AN INTERCHANGE. +C + CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) + DO 110 JJ = IMAX, K + J = K + IMAX - JJ + T = A(J,K) + A(J,K) = A(IMAX,J) + A(IMAX,J) = T + 110 CONTINUE + 120 CONTINUE +C +C PERFORM THE ELIMINATION. +C + DO 130 JJ = 1, KM1 + J = K - JJ + MULK = -A(J,K)/A(K,K) + T = MULK + CALL DAXPY(J,T,A(1,K),1,A(1,J),1) + A(J,K) = MULK + 130 CONTINUE +C +C SET THE PIVOT ARRAY. +C + KPVT(K) = K + IF (SWAP) KPVT(K) = IMAX + GO TO 190 + 140 CONTINUE +C +C 2 X 2 PIVOT BLOCK. +C + IF (.NOT.SWAP) GO TO 160 +C +C PERFORM AN INTERCHANGE. +C + CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) + DO 150 JJ = IMAX, KM1 + J = KM1 + IMAX - JJ + T = A(J,K-1) + A(J,K-1) = A(IMAX,J) + A(IMAX,J) = T + 150 CONTINUE + T = A(K-1,K) + A(K-1,K) = A(IMAX,K) + A(IMAX,K) = T + 160 CONTINUE +C +C PERFORM THE ELIMINATION. +C + KM2 = K - 2 + IF (KM2 .EQ. 0) GO TO 180 + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + DENOM = 1.0D0 - AK*AKM1 + DO 170 JJ = 1, KM2 + J = KM1 - JJ + BK = A(J,K)/A(K-1,K) + BKM1 = A(J,K-1)/A(K-1,K) + MULK = (AKM1*BK - BKM1)/DENOM + MULKM1 = (AK*BKM1 - BK)/DENOM + T = MULK + CALL DAXPY(J,T,A(1,K),1,A(1,J),1) + T = MULKM1 + CALL DAXPY(J,T,A(1,K-1),1,A(1,J),1) + A(J,K) = MULK + A(J,K-1) = MULKM1 + 170 CONTINUE + 180 CONTINUE +C +C SET THE PIVOT ARRAY. +C + KPVT(K) = 1 - K + IF (SWAP) KPVT(K) = -IMAX + KPVT(K-1) = KPVT(K) + 190 CONTINUE + K = K - KSTEP + GO TO 10 + 200 CONTINUE + RETURN + END diff --git a/SLATEC/src/dsisl.f b/SLATEC/src/dsisl.f new file mode 100644 index 0000000..b32121e --- /dev/null +++ b/SLATEC/src/dsisl.f @@ -0,0 +1,187 @@ +*DECK DSISL + SUBROUTINE DSISL (A, LDA, N, KPVT, B) +C***BEGIN PROLOGUE DSISL +C***PURPOSE Solve a real symmetric system using the factors obtained +C from SSIFA. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2B1A +C***TYPE DOUBLE PRECISION (SSISL-S, DSISL-D, CHISL-C, CSISL-C) +C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, SYMMETRIC +C***AUTHOR Bunch, J., (UCSD) +C***DESCRIPTION +C +C DSISL solves the double precision symmetric system +C A * X = B +C using the factors computed by DSIFA. +C +C On Entry +C +C A DOUBLE PRECISION(LDA,N) +C the output from DSIFA. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C KPVT INTEGER(N) +C the pivot vector from DSIFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero may occur if DSICO has set RCOND .EQ. 0.0 +C or DSIFA has set INFO .NE. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DSIFA(A,LDA,N,KPVT,INFO) +C IF (INFO .NE. 0) GO TO ... +C DO 10 J = 1, P +C CALL DSISL(A,LDA,N,KPVT,C(1,J)) +C 10 CONTINUE +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED DAXPY, DDOT +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891107 Modified routine equivalence list. (WRB) +C 891107 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DSISL + INTEGER LDA,N,KPVT(*) + DOUBLE PRECISION A(LDA,*),B(*) +C + DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP + INTEGER K,KP +C +C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND +C D INVERSE TO B. +C +C***FIRST EXECUTABLE STATEMENT DSISL + K = N + 10 IF (K .EQ. 0) GO TO 80 + IF (KPVT(K) .LT. 0) GO TO 40 +C +C 1 X 1 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 30 + KP = KPVT(K) + IF (KP .EQ. K) GO TO 20 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 20 CONTINUE +C +C APPLY THE TRANSFORMATION. +C + CALL DAXPY(K-1,B(K),A(1,K),1,B(1),1) + 30 CONTINUE +C +C APPLY D INVERSE. +C + B(K) = B(K)/A(K,K) + K = K - 1 + GO TO 70 + 40 CONTINUE +C +C 2 X 2 PIVOT BLOCK. +C + IF (K .EQ. 2) GO TO 60 + KP = ABS(KPVT(K)) + IF (KP .EQ. K - 1) GO TO 50 +C +C INTERCHANGE. +C + TEMP = B(K-1) + B(K-1) = B(KP) + B(KP) = TEMP + 50 CONTINUE +C +C APPLY THE TRANSFORMATION. +C + CALL DAXPY(K-2,B(K),A(1,K),1,B(1),1) + CALL DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) + 60 CONTINUE +C +C APPLY D INVERSE. +C + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = B(K)/A(K-1,K) + BKM1 = B(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + B(K) = (AKM1*BK - BKM1)/DENOM + B(K-1) = (AK*BKM1 - BK)/DENOM + K = K - 2 + 70 CONTINUE + GO TO 10 + 80 CONTINUE +C +C LOOP FORWARD APPLYING THE TRANSFORMATIONS. +C + K = 1 + 90 IF (K .GT. N) GO TO 160 + IF (KPVT(K) .LT. 0) GO TO 120 +C +C 1 X 1 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 110 +C +C APPLY THE TRANSFORMATION. +C + B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) + KP = KPVT(K) + IF (KP .EQ. K) GO TO 100 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 100 CONTINUE + 110 CONTINUE + K = K + 1 + GO TO 150 + 120 CONTINUE +C +C 2 X 2 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 140 +C +C APPLY THE TRANSFORMATION. +C + B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) + B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) + KP = ABS(KPVT(K)) + IF (KP .EQ. K) GO TO 130 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 130 CONTINUE + 140 CONTINUE + K = K + 2 + 150 CONTINUE + GO TO 90 + 160 CONTINUE + RETURN + END diff --git a/SLATEC/src/dsteps.f b/SLATEC/src/dsteps.f new file mode 100644 index 0000000..fb61a13 --- /dev/null +++ b/SLATEC/src/dsteps.f @@ -0,0 +1,577 @@ +*DECK DSTEPS + SUBROUTINE DSTEPS (DF, NEQN, Y, X, H, EPS, WT, START, HOLD, K, + + KOLD, CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G, + + PHASE1, NS, NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV, + + KGI, GI, RPAR, IPAR) +C***BEGIN PROLOGUE DSTEPS +C***PURPOSE Integrate a system of first order ordinary differential +C equations one step. +C***LIBRARY SLATEC (DEPAC) +C***CATEGORY I1A1B +C***TYPE DOUBLE PRECISION (STEPS-S, DSTEPS-D) +C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, +C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR +C***AUTHOR Shampine, L. F., (SNLA) +C Gordon, M. K., (SNLA) +C MODIFIED BY H.A. WATTS +C***DESCRIPTION +C +C Written by L. F. Shampine and M. K. Gordon +C +C Abstract +C +C Subroutine DSTEPS is normally used indirectly through subroutine +C DDEABM . Because DDEABM suffices for most problems and is much +C easier to use, using it should be considered before using DSTEPS +C alone. +C +C Subroutine DSTEPS integrates a system of NEQN first order ordinary +C differential equations one step, normally from X to X+H, using a +C modified divided difference form of the Adams Pece formulas. Local +C extrapolation is used to improve absolute stability and accuracy. +C The code adjusts its order and step size to control the local error +C per unit step in a generalized sense. Special devices are included +C to control roundoff error and to detect when the user is requesting +C too much accuracy. +C +C This code is completely explained and documented in the text, +C Computer Solution of Ordinary Differential Equations, The Initial +C Value Problem by L. F. Shampine and M. K. Gordon. +C Further details on use of this code are available in "Solving +C Ordinary Differential Equations with ODE, STEP, and INTRP", +C by L. F. Shampine and M. K. Gordon, SLA-73-1060. +C +C +C The parameters represent -- +C DF -- subroutine to evaluate derivatives +C NEQN -- number of equations to be integrated +C Y(*) -- solution vector at X +C X -- independent variable +C H -- appropriate step size for next step. Normally determined by +C code +C EPS -- local error tolerance +C WT(*) -- vector of weights for error criterion +C START -- logical variable set .TRUE. for first step, .FALSE. +C otherwise +C HOLD -- step size used for last successful step +C K -- appropriate order for next step (determined by code) +C KOLD -- order used for last successful step +C CRASH -- logical variable set .TRUE. when no step can be taken, +C .FALSE. otherwise. +C YP(*) -- derivative of solution vector at X after successful +C step +C KSTEPS -- counter on attempted steps +C TWOU -- 2.*U where U is machine unit roundoff quantity +C FOURU -- 4.*U where U is machine unit roundoff quantity +C RPAR,IPAR -- parameter arrays which you may choose to use +C for communication between your program and subroutine F. +C They are not altered or used by DSTEPS. +C The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G, +C W,P,IV and GI are required for the interpolation subroutine SINTRP. +C The remaining variables and arrays are included in the call list +C only to eliminate local retention of variables between calls. +C +C Input to DSTEPS +C +C First call -- +C +C The user must provide storage in his calling program for all arrays +C in the call list, namely +C +C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), +C 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), +C 2 RPAR(*),IPAR(*) +C +C **Note** +C +C The user must also declare START , CRASH , PHASE1 and NORND +C logical variables and DF an EXTERNAL subroutine, supply the +C subroutine DF(X,Y,YP) to evaluate +C DY(I)/DX = YP(I) = DF(X,Y(1),Y(2),...,Y(NEQN)) +C and initialize only the following parameters. +C NEQN -- number of equations to be integrated +C Y(*) -- vector of initial values of dependent variables +C X -- initial value of the independent variable +C H -- nominal step size indicating direction of integration +C and maximum size of step. Must be variable +C EPS -- local error tolerance per step. Must be variable +C WT(*) -- vector of non-zero weights for error criterion +C START -- .TRUE. +C YP(*) -- vector of initial derivative values +C KSTEPS -- set KSTEPS to zero +C TWOU -- 2.*U where U is machine unit roundoff quantity +C FOURU -- 4.*U where U is machine unit roundoff quantity +C Define U to be the machine unit roundoff quantity by calling +C the function routine D1MACH, U = D1MACH(4), or by +C computing U so that U is the smallest positive number such +C that 1.0+U .GT. 1.0. +C +C DSTEPS requires that the L2 norm of the vector with components +C LOCAL ERROR(L)/WT(L) be less than EPS for a successful step. The +C array WT allows the user to specify an error test appropriate +C for his problem. For example, +C WT(L) = 1.0 specifies absolute error, +C = ABS(Y(L)) error relative to the most recent value of the +C L-th component of the solution, +C = ABS(YP(L)) error relative to the most recent value of +C the L-th component of the derivative, +C = MAX(WT(L),ABS(Y(L))) error relative to the largest +C magnitude of L-th component obtained so far, +C = ABS(Y(L))*RELERR/EPS + ABSERR/EPS specifies a mixed +C relative-absolute test where RELERR is relative +C error, ABSERR is absolute error and EPS = +C MAX(RELERR,ABSERR) . +C +C Subsequent calls -- +C +C Subroutine DSTEPS is designed so that all information needed to +C continue the integration, including the step size H and the order +C K , is returned with each step. With the exception of the step +C size, the error tolerance, and the weights, none of the parameters +C should be altered. The array WT must be updated after each step +C to maintain relative error tests like those above. Normally the +C integration is continued just beyond the desired endpoint and the +C solution interpolated there with subroutine SINTRP . If it is +C impossible to integrate beyond the endpoint, the step size may be +C reduced to hit the endpoint since the code will not take a step +C larger than the H input. Changing the direction of integration, +C i.e., the sign of H , requires the user set START = .TRUE. before +C calling DSTEPS again. This is the only situation in which START +C should be altered. +C +C Output from DSTEPS +C +C Successful Step -- +C +C The subroutine returns after each successful step with START and +C CRASH set .FALSE. . X represents the independent variable +C advanced one step of length HOLD from its value on input and Y +C the solution vector at the new value of X . All other parameters +C represent information corresponding to the new X needed to +C continue the integration. +C +C Unsuccessful Step -- +C +C When the error tolerance is too small for the machine precision, +C the subroutine returns without taking a step and CRASH = .TRUE. . +C An appropriate step size and error tolerance for continuing are +C estimated and all other information is restored as upon input +C before returning. To continue with the larger tolerance, the user +C just calls the code again. A restart is neither required nor +C desirable. +C +C***REFERENCES L. F. Shampine and M. K. Gordon, Solving ordinary +C differential equations with ODE, STEP, and INTRP, +C Report SLA-73-1060, Sandia Laboratories, 1973. +C***ROUTINES CALLED D1MACH, DHSTRT +C***REVISION HISTORY (YYMMDD) +C 740101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DSTEPS +C + INTEGER I, IFAIL, IM1, IP1, IPAR, IQ, J, K, KM1, KM2, KNEW, + 1 KOLD, KP1, KP2, KSTEPS, L, LIMIT1, LIMIT2, NEQN, NS, NSM2, + 2 NSP1, NSP2 + DOUBLE PRECISION ABSH, ALPHA, BETA, BIG, D1MACH, + 1 EPS, ERK, ERKM1, ERKM2, ERKP1, ERR, + 2 FOURU, G, GI, GSTR, H, HNEW, HOLD, P, P5EPS, PHI, PSI, R, + 3 REALI, REALNS, RHO, ROUND, RPAR, SIG, TAU, TEMP1, + 4 TEMP2, TEMP3, TEMP4, TEMP5, TEMP6, TWO, TWOU, U, V, W, WT, + 5 X, XOLD, Y, YP + LOGICAL START,CRASH,PHASE1,NORND + DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12), + 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), + 2 RPAR(*),IPAR(*) + DIMENSION TWO(13),GSTR(13) + EXTERNAL DF + SAVE TWO, GSTR +C + DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8), + 1 TWO(9),TWO(10),TWO(11),TWO(12),TWO(13) + 2 /2.0D0,4.0D0,8.0D0,16.0D0,32.0D0,64.0D0,128.0D0,256.0D0, + 3 512.0D0,1024.0D0,2048.0D0,4096.0D0,8192.0D0/ + DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7), + 1 GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13) + 2 /0.5D0,0.0833D0,0.0417D0,0.0264D0,0.0188D0,0.0143D0,0.0114D0, + 3 0.00936D0,0.00789D0,0.00679D0,0.00592D0,0.00524D0,0.00468D0/ +C +C *** BEGIN BLOCK 0 *** +C CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE +C PRECISION. IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A +C STARTING STEP SIZE. +C *** +C +C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE +C +C***FIRST EXECUTABLE STATEMENT DSTEPS + CRASH = .TRUE. + IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5 + H = SIGN(FOURU*ABS(X),H) + RETURN + 5 P5EPS = 0.5D0*EPS +C +C IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE +C + ROUND = 0.0D0 + DO 10 L = 1,NEQN + 10 ROUND = ROUND + (Y(L)/WT(L))**2 + ROUND = TWOU*SQRT(ROUND) + IF(P5EPS .GE. ROUND) GO TO 15 + EPS = 2.0D0*ROUND*(1.0D0 + FOURU) + RETURN + 15 CRASH = .FALSE. + G(1) = 1.0D0 + G(2) = 0.5D0 + SIG(1) = 1.0D0 + IF(.NOT.START) GO TO 99 +C +C INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP +C +C CALL DF(X,Y,YP,RPAR,IPAR) +C SUM = 0.0 + DO 20 L = 1,NEQN + PHI(L,1) = YP(L) + 20 PHI(L,2) = 0.0D0 +C20 SUM = SUM + (YP(L)/WT(L))**2 +C SUM = SQRT(SUM) +C ABSH = ABS(H) +C IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) +C H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) +C + U = D1MACH(4) + BIG = SQRT(D1MACH(2)) + CALL DHSTRT(DF,NEQN,X,X+H,Y,YP,WT,1,U,BIG, + 1 PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) +C + HOLD = 0.0D0 + K = 1 + KOLD = 0 + KPREV = 0 + START = .FALSE. + PHASE1 = .TRUE. + NORND = .TRUE. + IF(P5EPS .GT. 100.0D0*ROUND) GO TO 99 + NORND = .FALSE. + DO 25 L = 1,NEQN + 25 PHI(L,15) = 0.0D0 + 99 IFAIL = 0 +C *** END BLOCK 0 *** +C +C *** BEGIN BLOCK 1 *** +C COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING +C THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. +C *** +C + 100 KP1 = K+1 + KP2 = K+2 + KM1 = K-1 + KM2 = K-2 +C +C NS IS THE NUMBER OF DSTEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT +C ONE. WHEN K.LT.NS, NO COEFFICIENTS CHANGE +C + IF(H .NE. HOLD) NS = 0 + IF (NS.LE.KOLD) NS = NS+1 + NSP1 = NS+1 + IF (K .LT. NS) GO TO 199 +C +C COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH +C ARE CHANGED +C + BETA(NS) = 1.0D0 + REALNS = NS + ALPHA(NS) = 1.0D0/REALNS + TEMP1 = H*REALNS + SIG(NSP1) = 1.0D0 + IF(K .LT. NSP1) GO TO 110 + DO 105 I = NSP1,K + IM1 = I-1 + TEMP2 = PSI(IM1) + PSI(IM1) = TEMP1 + BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2 + TEMP1 = TEMP2 + H + ALPHA(I) = H/TEMP1 + REALI = I + 105 SIG(I+1) = REALI*ALPHA(I)*SIG(I) + 110 PSI(K) = TEMP1 +C +C COMPUTE COEFFICIENTS G(*) +C +C INITIALIZE V(*) AND SET W(*). +C + IF(NS .GT. 1) GO TO 120 + DO 115 IQ = 1,K + TEMP3 = IQ*(IQ+1) + V(IQ) = 1.0D0/TEMP3 + 115 W(IQ) = V(IQ) + IVC = 0 + KGI = 0 + IF (K .EQ. 1) GO TO 140 + KGI = 1 + GI(1) = W(2) + GO TO 140 +C +C IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) +C + 120 IF(K .LE. KPREV) GO TO 130 + IF (IVC .EQ. 0) GO TO 122 + JV = KP1 - IV(IVC) + IVC = IVC - 1 + GO TO 123 + 122 JV = 1 + TEMP4 = K*KP1 + V(K) = 1.0D0/TEMP4 + W(K) = V(K) + IF (K .NE. 2) GO TO 123 + KGI = 1 + GI(1) = W(2) + 123 NSM2 = NS-2 + IF(NSM2 .LT. JV) GO TO 130 + DO 125 J = JV,NSM2 + I = K-J + V(I) = V(I) - ALPHA(J+1)*V(I+1) + 125 W(I) = V(I) + IF (I .NE. 2) GO TO 130 + KGI = NS - 1 + GI(KGI) = W(2) +C +C UPDATE V(*) AND SET W(*) +C + 130 LIMIT1 = KP1 - NS + TEMP5 = ALPHA(NS) + DO 135 IQ = 1,LIMIT1 + V(IQ) = V(IQ) - TEMP5*V(IQ+1) + 135 W(IQ) = V(IQ) + G(NSP1) = W(1) + IF (LIMIT1 .EQ. 1) GO TO 137 + KGI = NS + GI(KGI) = W(2) + 137 W(LIMIT1+1) = V(LIMIT1+1) + IF (K .GE. KOLD) GO TO 140 + IVC = IVC + 1 + IV(IVC) = LIMIT1 + 2 +C +C COMPUTE THE G(*) IN THE WORK VECTOR W(*) +C + 140 NSP2 = NS + 2 + KPREV = K + IF(KP1 .LT. NSP2) GO TO 199 + DO 150 I = NSP2,KP1 + LIMIT2 = KP2 - I + TEMP6 = ALPHA(I-1) + DO 145 IQ = 1,LIMIT2 + 145 W(IQ) = W(IQ) - TEMP6*W(IQ+1) + 150 G(I) = W(1) + 199 CONTINUE +C *** END BLOCK 1 *** +C +C *** BEGIN BLOCK 2 *** +C PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED +C SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, +C K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED. +C *** +C +C INCREMENT COUNTER ON ATTEMPTED DSTEPS +C + KSTEPS = KSTEPS + 1 +C +C CHANGE PHI TO PHI STAR +C + IF(K .LT. NSP1) GO TO 215 + DO 210 I = NSP1,K + TEMP1 = BETA(I) + DO 205 L = 1,NEQN + 205 PHI(L,I) = TEMP1*PHI(L,I) + 210 CONTINUE +C +C PREDICT SOLUTION AND DIFFERENCES +C + 215 DO 220 L = 1,NEQN + PHI(L,KP2) = PHI(L,KP1) + PHI(L,KP1) = 0.0D0 + 220 P(L) = 0.0D0 + DO 230 J = 1,K + I = KP1 - J + IP1 = I+1 + TEMP2 = G(I) + DO 225 L = 1,NEQN + P(L) = P(L) + TEMP2*PHI(L,I) + 225 PHI(L,I) = PHI(L,I) + PHI(L,IP1) + 230 CONTINUE + IF(NORND) GO TO 240 + DO 235 L = 1,NEQN + TAU = H*P(L) - PHI(L,15) + P(L) = Y(L) + TAU + 235 PHI(L,16) = (P(L) - Y(L)) - TAU + GO TO 250 + 240 DO 245 L = 1,NEQN + 245 P(L) = Y(L) + H*P(L) + 250 XOLD = X + X = X + H + ABSH = ABS(H) + CALL DF(X,P,YP,RPAR,IPAR) +C +C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 +C + ERKM2 = 0.0D0 + ERKM1 = 0.0D0 + ERK = 0.0D0 + DO 265 L = 1,NEQN + TEMP3 = 1.0D0/WT(L) + TEMP4 = YP(L) - PHI(L,1) + IF(KM2)265,260,255 + 255 ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 + 260 ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 + 265 ERK = ERK + (TEMP4*TEMP3)**2 + IF(KM2)280,275,270 + 270 ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) + 275 ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) + 280 TEMP5 = ABSH*SQRT(ERK) + ERR = TEMP5*(G(K)-G(KP1)) + ERK = TEMP5*SIG(KP1)*GSTR(K) + KNEW = K +C +C TEST IF ORDER SHOULD BE LOWERED +C + IF(KM2)299,290,285 + 285 IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1 + GO TO 299 + 290 IF(ERKM1 .LE. 0.5D0*ERK) KNEW = KM1 +C +C TEST IF STEP SUCCESSFUL +C + 299 IF(ERR .LE. EPS) GO TO 400 +C *** END BLOCK 2 *** +C +C *** BEGIN BLOCK 3 *** +C THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . +C IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE +C THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR +C TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE +C PRECISION. +C *** +C +C RESTORE X, PHI(*,*) AND PSI(*) +C + PHASE1 = .FALSE. + X = XOLD + DO 310 I = 1,K + TEMP1 = 1.0D0/BETA(I) + IP1 = I+1 + DO 305 L = 1,NEQN + 305 PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1)) + 310 CONTINUE + IF(K .LT. 2) GO TO 320 + DO 315 I = 2,K + 315 PSI(I-1) = PSI(I) - H +C +C ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP +C SIZE +C + 320 IFAIL = IFAIL + 1 + TEMP2 = 0.5D0 + IF(IFAIL - 3) 335,330,325 + 325 IF(P5EPS .LT. 0.25D0*ERK) TEMP2 = SQRT(P5EPS/ERK) + 330 KNEW = 1 + 335 H = TEMP2*H + K = KNEW + NS = 0 + IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340 + CRASH = .TRUE. + H = SIGN(FOURU*ABS(X),H) + EPS = EPS + EPS + RETURN + 340 GO TO 100 +C *** END BLOCK 3 *** +C +C *** BEGIN BLOCK 4 *** +C THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE +C THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE +C DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. +C *** + 400 KOLD = K + HOLD = H +C +C CORRECT AND EVALUATE +C + TEMP1 = H*G(KP1) + IF(NORND) GO TO 410 + DO 405 L = 1,NEQN + TEMP3 = Y(L) + RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) + Y(L) = P(L) + RHO + PHI(L,15) = (Y(L) - P(L)) - RHO + 405 P(L) = TEMP3 + GO TO 420 + 410 DO 415 L = 1,NEQN + TEMP3 = Y(L) + Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) + 415 P(L) = TEMP3 + 420 CALL DF(X,Y,YP,RPAR,IPAR) +C +C UPDATE DIFFERENCES FOR NEXT STEP +C + DO 425 L = 1,NEQN + PHI(L,KP1) = YP(L) - PHI(L,1) + 425 PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2) + DO 435 I = 1,K + DO 430 L = 1,NEQN + 430 PHI(L,I) = PHI(L,I) + PHI(L,KP1) + 435 CONTINUE +C +C ESTIMATE ERROR AT ORDER K+1 UNLESS: +C IN FIRST PHASE WHEN ALWAYS RAISE ORDER, +C ALREADY DECIDED TO LOWER ORDER, +C STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE +C + ERKP1 = 0.0D0 + IF(KNEW .EQ. KM1 .OR. K .EQ. 12) PHASE1 = .FALSE. + IF(PHASE1) GO TO 450 + IF(KNEW .EQ. KM1) GO TO 455 + IF(KP1 .GT. NS) GO TO 460 + DO 440 L = 1,NEQN + 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 + ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) +C +C USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER +C FOR NEXT STEP +C + IF(K .GT. 1) GO TO 445 + IF(ERKP1 .GE. 0.5D0*ERK) GO TO 460 + GO TO 450 + 445 IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455 + IF(ERKP1 .GE. ERK .OR. K .EQ. 12) GO TO 460 +C +C HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE +C BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED +C +C RAISE ORDER +C + 450 K = KP1 + ERK = ERKP1 + GO TO 460 +C +C LOWER ORDER +C + 455 K = KM1 + ERK = ERKM1 +C +C WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP +C + 460 HNEW = H + H + IF(PHASE1) GO TO 465 + IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465 + HNEW = H + IF(P5EPS .GE. ERK) GO TO 465 + TEMP2 = K+1 + R = (P5EPS/ERK)**(1.0D0/TEMP2) + HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R)) + HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) + 465 H = HNEW + RETURN +C *** END BLOCK 4 *** + END diff --git a/SLATEC/src/dswap.f b/SLATEC/src/dswap.f new file mode 100644 index 0000000..441e601 --- /dev/null +++ b/SLATEC/src/dswap.f @@ -0,0 +1,102 @@ +*DECK DSWAP + SUBROUTINE DSWAP (N, DX, INCX, DY, INCY) +C***BEGIN PROLOGUE DSWAP +C***PURPOSE Interchange two vectors. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A5 +C***TYPE DOUBLE PRECISION (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) +C***KEYWORDS BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C DY double precision vector with N elements +C INCY storage spacing between elements of DY +C +C --Output-- +C DX input vector DY (unchanged if N .LE. 0) +C DY input vector DX (unchanged if N .LE. 0) +C +C Interchange double precision DX and double precision DY. +C For I = 0 to N-1, interchange DX(LX+I*INCX) and DY(LY+I*INCY), +C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is +C defined in a similar way using INCY. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920310 Corrected definition of LX in DESCRIPTION. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DSWAP + DOUBLE PRECISION DX(*), DY(*), DTEMP1, DTEMP2, DTEMP3 +C***FIRST EXECUTABLE STATEMENT DSWAP + IF (N .LE. 0) RETURN + IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 +C +C Code for unequal or nonpositive increments. +C + 5 IX = 1 + IY = 1 + IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 + IF (INCY .LT. 0) IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP1 = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP1 + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C Code for both increments equal to 1. +C +C Clean-up loop so remaining vector length is a multiple of 3. +C + 20 M = MOD(N,3) + IF (M .EQ. 0) GO TO 40 + DO 30 I = 1,M + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 30 CONTINUE + IF (N .LT. 3) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP1 = DX(I) + DTEMP2 = DX(I+1) + DTEMP3 = DX(I+2) + DX(I) = DY(I) + DX(I+1) = DY(I+1) + DX(I+2) = DY(I+2) + DY(I) = DTEMP1 + DY(I+1) = DTEMP2 + DY(I+2) = DTEMP3 + 50 CONTINUE + RETURN +C +C Code for equal, positive, non-unit increments. +C + 60 NS = N*INCX + DO 70 I = 1,NS,INCX + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 70 CONTINUE + RETURN + END diff --git a/SLATEC/src/fdump.f b/SLATEC/src/fdump.f new file mode 100644 index 0000000..1f44a57 --- /dev/null +++ b/SLATEC/src/fdump.f @@ -0,0 +1,31 @@ +*DECK FDUMP + SUBROUTINE FDUMP +C***BEGIN PROLOGUE FDUMP +C***PURPOSE Symbolic dump (should be locally written). +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (FDUMP-A) +C***KEYWORDS ERROR, XERMSG +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C ***Note*** Machine Dependent Routine +C FDUMP is intended to be replaced by a locally written +C version which produces a symbolic dump. Failing this, +C it should be replaced by a version which prints the +C subprogram nesting list. Note that this dump must be +C printed on each of up to five files, as indicated by the +C XGETUA routine. See XSETUA and XGETUA for details. +C +C Written by Ron Jones, with SLATEC Common Math Library Subcommittee +C +C***REFERENCES (NONE) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE FDUMP +C***FIRST EXECUTABLE STATEMENT FDUMP + RETURN + END diff --git a/SLATEC/src/i1mach.f b/SLATEC/src/i1mach.f new file mode 100644 index 0000000..ad04e7b --- /dev/null +++ b/SLATEC/src/i1mach.f @@ -0,0 +1,888 @@ +*DECK I1MACH + INTEGER FUNCTION I1MACH (I) +C***BEGIN PROLOGUE I1MACH +C***PURPOSE Return integer machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE INTEGER (I1MACH-I) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C I1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument and can be referenced as follows: +C +C K = I1MACH(I) +C +C where I=1,...,16. The (output) value of K above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C I/O unit numbers: +C I1MACH( 1) = the standard input unit. +C I1MACH( 2) = the standard output unit. +C I1MACH( 3) = the standard punch unit. +C I1MACH( 4) = the standard error message unit. +C +C Words: +C I1MACH( 5) = the number of bits per integer storage unit. +C I1MACH( 6) = the number of characters per integer storage unit. +C +C Integers: +C assume integers are represented in the S-digit, base-A form +C +C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C where 0 .LE. X(I) .LT. A for I=0,...,S-1. +C I1MACH( 7) = A, the base. +C I1MACH( 8) = S, the number of base-A digits. +C I1MACH( 9) = A**S - 1, the largest magnitude. +C +C Floating-Point Numbers: +C Assume floating-point numbers are represented in the T-digit, +C base-B form +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, +C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, the base. +C +C Single-Precision: +C I1MACH(11) = T, the number of base-B digits. +C I1MACH(12) = EMIN, the smallest exponent E. +C I1MACH(13) = EMAX, the largest exponent E. +C +C Double-Precision: +C I1MACH(14) = T, the number of base-B digits. +C I1MACH(15) = EMIN, the smallest exponent E. +C I1MACH(16) = EMAX, the largest exponent E. +C +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 891012 Added VAX G-floating constants. (WRB) +C 891012 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. +C (RWC) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added Convex -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler +C options. (DWL, RWC and WRB). +C***END PROLOGUE I1MACH +C + INTEGER IMACH(16),OUTPUT + SAVE IMACH + EQUIVALENCE (IMACH(4),OUTPUT) +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 129 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1025 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA IMACH( 1) / 7 / +C DATA IMACH( 2) / 2 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 33 / +C DATA IMACH( 9) / Z1FFFFFFFF / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -256 / +C DATA IMACH(13) / 255 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -256 / +C DATA IMACH(16) / 255 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -50 / +C DATA IMACH(16) / 76 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -32754 / +C DATA IMACH(16) / 32780 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -4095 / +C DATA IMACH(13) / 4094 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -4095 / +C DATA IMACH(16) / 4094 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6LOUTPUT/ +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / 00007777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z'7FFFFFFF' / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16383 / +C DATA IMACH(16) / 16383 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -pd8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 46 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 46 / +C DATA IMACH( 9) / 1777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 64 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 777777777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C +C DATA IMACH( 1) / 11 / +C DATA IMACH( 2) / 12 / +C DATA IMACH( 3) / 8 / +C DATA IMACH( 4) / 10 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / 3 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 23 / +C DATA IMACH( 9) / 8388607 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 38 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 43 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 39 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 55 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 7 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1015 / +C DATA IMACH(16) / 1017 / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z7FFFFFFF / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE IBM PC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 54 / +C DATA IMACH(15) / -101 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 62 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1021 / +C DATA IMACH(13) / 1024 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16381 / +C DATA IMACH(16) / 16384 / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 1 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -1024 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR +C +C DATA IMACH( 1) / 1 / +C DATA IMACH( 2) / 1 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C***FIRST EXECUTABLE STATEMENT I1MACH + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) + RETURN +C + 10 CONTINUE + WRITE (UNIT = OUTPUT, FMT = 9000) + 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') +C +C CALL FDUMP +C + STOP + END diff --git a/SLATEC/src/idamax.f b/SLATEC/src/idamax.f new file mode 100644 index 0000000..f6e6afa --- /dev/null +++ b/SLATEC/src/idamax.f @@ -0,0 +1,82 @@ +*DECK IDAMAX + INTEGER FUNCTION IDAMAX (N, DX, INCX) +C***BEGIN PROLOGUE IDAMAX +C***PURPOSE Find the smallest index of that component of a vector +C having the maximum magnitude. +C***LIBRARY SLATEC (BLAS) +C***CATEGORY D1A2 +C***TYPE DOUBLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C) +C***KEYWORDS BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR +C***AUTHOR Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***DESCRIPTION +C +C B L A S Subprogram +C Description of Parameters +C +C --Input-- +C N number of elements in input vector(s) +C DX double precision vector with N elements +C INCX storage spacing between elements of DX +C +C --Output-- +C IDAMAX smallest index (zero if N .LE. 0) +C +C Find smallest index of maximum magnitude of double precision DX. +C IDAMAX = first I, I = 1 to N, to maximize ABS(DX(IX+(I-1)*INCX)), +C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. +C +C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +C Krogh, Basic linear algebra subprograms for Fortran +C usage, Algorithm No. 539, Transactions on Mathematical +C Software 5, 3 (September 1979), pp. 308-323. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 791001 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890531 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900821 Modified to correct problem with a negative increment. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE IDAMAX + DOUBLE PRECISION DX(*), DMAX, XMAG + INTEGER I, INCX, IX, N +C***FIRST EXECUTABLE STATEMENT IDAMAX + IDAMAX = 0 + IF (N .LE. 0) RETURN + IDAMAX = 1 + IF (N .EQ. 1) RETURN +C + IF (INCX .EQ. 1) GOTO 20 +C +C Code for increments not equal to 1. +C + IX = 1 + IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 + DMAX = ABS(DX(IX)) + IX = IX + INCX + DO 10 I = 2,N + XMAG = ABS(DX(IX)) + IF (XMAG .GT. DMAX) THEN + IDAMAX = I + DMAX = XMAG + ENDIF + IX = IX + INCX + 10 CONTINUE + RETURN +C +C Code for increments equal to 1. +C + 20 DMAX = ABS(DX(1)) + DO 30 I = 2,N + XMAG = ABS(DX(I)) + IF (XMAG .GT. DMAX) THEN + IDAMAX = I + DMAX = XMAG + ENDIF + 30 CONTINUE + RETURN + END diff --git a/SLATEC/src/initds.f b/SLATEC/src/initds.f new file mode 100644 index 0000000..36eca15 --- /dev/null +++ b/SLATEC/src/initds.f @@ -0,0 +1,54 @@ +*DECK INITDS + FUNCTION INITDS (OS, NOS, ETA) +C***BEGIN PROLOGUE INITDS +C***PURPOSE Determine the number of terms needed in an orthogonal +C polynomial series so that it meets a specified accuracy. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C3A2 +C***TYPE DOUBLE PRECISION (INITS-S, INITDS-D) +C***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, +C ORTHOGONAL SERIES, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Initialize the orthogonal series, represented by the array OS, so +C that INITDS is the number of terms needed to insure the error is no +C larger than ETA. Ordinarily, ETA will be chosen to be one-tenth +C machine precision. +C +C Input Arguments -- +C OS double precision array of NOS coefficients in an orthogonal +C series. +C NOS number of coefficients in OS. +C ETA single precision scalar containing requested accuracy of +C series. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891115 Modified error message. (WRB) +C 891115 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE INITDS + DOUBLE PRECISION OS(*) +C***FIRST EXECUTABLE STATEMENT INITDS + IF (NOS .LT. 1) CALL XERMSG ('SLATEC', 'INITDS', + + 'Number of coefficients is less than 1', 2, 1) +C + ERR = 0. + DO 10 II = 1,NOS + I = NOS + 1 - II + ERR = ERR + ABS(REAL(OS(I))) + IF (ERR.GT.ETA) GO TO 20 + 10 CONTINUE +C + 20 IF (I .EQ. NOS) CALL XERMSG ('SLATEC', 'INITDS', + + 'Chebyshev series too short for specified accuracy', 1, 1) + INITDS = I +C + RETURN + END diff --git a/SLATEC/src/j4save.f b/SLATEC/src/j4save.f new file mode 100644 index 0000000..6ec799b --- /dev/null +++ b/SLATEC/src/j4save.f @@ -0,0 +1,65 @@ +*DECK J4SAVE + FUNCTION J4SAVE (IWHICH, IVALUE, ISET) +C***BEGIN PROLOGUE J4SAVE +C***SUBSIDIARY +C***PURPOSE Save or recall global variables needed by error +C handling routines. +C***LIBRARY SLATEC (XERROR) +C***TYPE INTEGER (J4SAVE-I) +C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C J4SAVE saves and recalls several global variables needed +C by the library error handling routines. +C +C Description of Parameters +C --Input-- +C IWHICH - Index of item desired. +C = 1 Refers to current error number. +C = 2 Refers to current error control flag. +C = 3 Refers to current unit number to which error +C messages are to be sent. (0 means use standard.) +C = 4 Refers to the maximum number of times any +C message is to be printed (as set by XERMAX). +C = 5 Refers to the total number of units to which +C each error message is to be written. +C = 6 Refers to the 2nd unit for error messages +C = 7 Refers to the 3rd unit for error messages +C = 8 Refers to the 4th unit for error messages +C = 9 Refers to the 5th unit for error messages +C IVALUE - The value to be set for the IWHICH-th parameter, +C if ISET is .TRUE. . +C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE +C given the value, IVALUE. If ISET=.FALSE., the +C IWHICH-th parameter will be unchanged, and IVALUE +C is a dummy parameter. +C --Output-- +C The (old) value of the IWHICH-th parameter will be returned +C in the function value, J4SAVE. +C +C***SEE ALSO XERMSG +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900205 Minor modifications to prologue. (WRB) +C 900402 Added TYPE section. (WRB) +C 910411 Added KEYWORDS section. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE J4SAVE + LOGICAL ISET + INTEGER IPARAM(9) + SAVE IPARAM + DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ + DATA IPARAM(5)/1/ + DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ +C***FIRST EXECUTABLE STATEMENT J4SAVE + J4SAVE = IPARAM(IWHICH) + IF (ISET) IPARAM(IWHICH) = IVALUE + RETURN + END diff --git a/SLATEC/src/xercnt.f b/SLATEC/src/xercnt.f new file mode 100644 index 0000000..06c82ab --- /dev/null +++ b/SLATEC/src/xercnt.f @@ -0,0 +1,60 @@ +*DECK XERCNT + SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) +C***BEGIN PROLOGUE XERCNT +C***SUBSIDIARY +C***PURPOSE Allow user control over handling of errors. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERCNT-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C Allows user control over handling of individual errors. +C Just after each message is recorded, but before it is +C processed any further (i.e., before it is printed or +C a decision to abort is made), a call is made to XERCNT. +C If the user has provided his own version of XERCNT, he +C can then override the value of KONTROL used in processing +C this message by redefining its value. +C KONTRL may be set to any value from -2 to 2. +C The meanings for KONTRL are the same as in XSETF, except +C that the value of KONTRL changes only for this message. +C If KONTRL is set to a value outside the range from -2 to 2, +C it will be moved back into that range. +C +C Description of Parameters +C +C --Input-- +C LIBRAR - the library that the routine is in. +C SUBROU - the subroutine that XERMSG is being called from +C MESSG - the first 20 characters of the error message. +C NERR - same as in the call to XERMSG. +C LEVEL - same as in the call to XERMSG. +C KONTRL - the current value of the control flag as set +C by a call to XSETF. +C +C --Output-- +C KONTRL - the new value of KONTRL. If KONTRL is not +C defined, it will remain at its original value. +C This changed value of control affects only +C the current occurrence of the current message. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE +C names, changed routine name from XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERCNT + CHARACTER*(*) LIBRAR, SUBROU, MESSG +C***FIRST EXECUTABLE STATEMENT XERCNT + RETURN + END diff --git a/SLATEC/src/xerhlt.f b/SLATEC/src/xerhlt.f new file mode 100644 index 0000000..89b2a77 --- /dev/null +++ b/SLATEC/src/xerhlt.f @@ -0,0 +1,39 @@ +*DECK XERHLT + SUBROUTINE XERHLT (MESSG) +C***BEGIN PROLOGUE XERHLT +C***SUBSIDIARY +C***PURPOSE Abort program execution and print error message. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERHLT-A) +C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C ***Note*** machine dependent routine +C XERHLT aborts the execution of the program. +C The error message causing the abort is given in the calling +C sequence, in case one needs it for printing on a dayfile, +C for example. +C +C Description of Parameters +C MESSG is as in XERMSG. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to delete length of character +C and changed routine name from XERABT to XERHLT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERHLT + CHARACTER*(*) MESSG +C***FIRST EXECUTABLE STATEMENT XERHLT + STOP + END diff --git a/SLATEC/src/xermsg.f b/SLATEC/src/xermsg.f new file mode 100644 index 0000000..46c83ec --- /dev/null +++ b/SLATEC/src/xermsg.f @@ -0,0 +1,364 @@ +*DECK XERMSG + SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) +C***BEGIN PROLOGUE XERMSG +C***PURPOSE Process error messages for SLATEC and other libraries. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERMSG-A) +C***KEYWORDS ERROR MESSAGE, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C XERMSG processes a diagnostic message in a manner determined by the +C value of LEVEL and the current value of the library error control +C flag, KONTRL. See subroutine XSETF for details. +C +C LIBRAR A character constant (or character variable) with the name +C of the library. This will be 'SLATEC' for the SLATEC +C Common Math Library. The error handling package is +C general enough to be used by many libraries +C simultaneously, so it is desirable for the routine that +C detects and reports an error to identify the library name +C as well as the routine name. +C +C SUBROU A character constant (or character variable) with the name +C of the routine that detected the error. Usually it is the +C name of the routine that is calling XERMSG. There are +C some instances where a user callable library routine calls +C lower level subsidiary routines where the error is +C detected. In such cases it may be more informative to +C supply the name of the routine the user called rather than +C the name of the subsidiary routine that detected the +C error. +C +C MESSG A character constant (or character variable) with the text +C of the error or warning message. In the example below, +C the message is a character constant that contains a +C generic message. +C +C CALL XERMSG ('SLATEC', 'MMPY', +C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', +C *3, 1) +C +C It is possible (and is sometimes desirable) to generate a +C specific message--e.g., one that contains actual numeric +C values. Specific numeric values can be converted into +C character strings using formatted WRITE statements into +C character variables. This is called standard Fortran +C internal file I/O and is exemplified in the first three +C lines of the following example. You can also catenate +C substrings of characters to construct the error message. +C Here is an example showing the use of both writing to +C an internal file and catenating character strings. +C +C CHARACTER*5 CHARN, CHARL +C WRITE (CHARN,10) N +C WRITE (CHARL,10) LDA +C 10 FORMAT(I5) +C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// +C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// +C * CHARL, 3, 1) +C +C There are two subtleties worth mentioning. One is that +C the // for character catenation is used to construct the +C error message so that no single character constant is +C continued to the next line. This avoids confusion as to +C whether there are trailing blanks at the end of the line. +C The second is that by catenating the parts of the message +C as an actual argument rather than encoding the entire +C message into one large character variable, we avoid +C having to know how long the message will be in order to +C declare an adequate length for that large character +C variable. XERMSG calls XERPRN to print the message using +C multiple lines if necessary. If the message is very long, +C XERPRN will break it into pieces of 72 characters (as +C requested by XERMSG) for printing on multiple lines. +C Also, XERMSG asks XERPRN to prefix each line with ' * ' +C so that the total line length could be 76 characters. +C Note also that XERPRN scans the error message backwards +C to ignore trailing blanks. Another feature is that +C the substring '$$' is treated as a new line sentinel +C by XERPRN. If you want to construct a multiline +C message without having to count out multiples of 72 +C characters, just use '$$' as a separator. '$$' +C obviously must occur within 72 characters of the +C start of each line to have its intended effect since +C XERPRN is asked to wrap around at 72 characters in +C addition to looking for '$$'. +C +C NERR An integer value that is chosen by the library routine's +C author. It must be in the range -99 to 999 (three +C printable digits). Each distinct error should have its +C own error number. These error numbers should be described +C in the machine readable documentation for the routine. +C The error numbers need be unique only within each routine, +C so it is reasonable for each routine to start enumerating +C errors from 1 and proceeding to the next integer. +C +C LEVEL An integer value in the range 0 to 2 that indicates the +C level (severity) of the error. Their meanings are +C +C -1 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. An attempt is made to only print this +C message once. +C +C 0 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. +C +C 1 A recoverable error. This is used even if the error is +C so serious that the routine cannot return any useful +C answer. If the user has told the error package to +C return after recoverable errors, then XERMSG will +C return to the Library routine which can then return to +C the user's routine. The user may also permit the error +C package to terminate the program upon encountering a +C recoverable error. +C +C 2 A fatal error. XERMSG will not return to its caller +C after it receives a fatal error. This level should +C hardly ever be used; it is much better to allow the +C user a chance to recover. An example of one of the few +C cases in which it is permissible to declare a level 2 +C error is a reverse communication Library routine that +C is likely to be called repeatedly until it integrates +C across some interval. If there is a serious error in +C the input such that another step cannot be taken and +C the Library routine is called again without the input +C error having been corrected by the caller, the Library +C routine will probably be called forever with improper +C input. In this case, it is reasonable to declare the +C error to be fatal. +C +C Each of the arguments to XERMSG is input; none will be modified by +C XERMSG. A routine may make multiple calls to XERMSG with warning +C level messages; however, after a call to XERMSG with a recoverable +C error, the routine should return to the user. Do not try to call +C XERMSG with a second recoverable error after the first recoverable +C error because the error package saves the error number. The user +C can retrieve this error number by calling another entry point in +C the error handling package and then clear the error number when +C recovering from the error. Calling XERMSG in succession causes the +C old error number to be overwritten by the latest error number. +C This is considered harmless for error numbers associated with +C warning messages but must not be done for error numbers of serious +C errors. After a call to XERMSG with a recoverable error, the user +C must be given a chance to call NUMXER or XERCLR to retrieve or +C clear the error number. +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE +C***REVISION HISTORY (YYMMDD) +C 880101 DATE WRITTEN +C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. +C THERE ARE TWO BASIC CHANGES. +C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO +C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES +C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS +C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE +C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER +C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY +C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE +C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. +C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE +C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE +C OF LOWER CASE. +C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. +C THE PRINCIPAL CHANGES ARE +C 1. CLARIFY COMMENTS IN THE PROLOGUES +C 2. RENAME XRPRNT TO XERPRN +C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES +C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / +C CHARACTER FOR NEW RECORDS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C CLEAN UP THE CODING. +C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN +C PREFIX. +C 891013 REVISED TO CORRECT COMMENTS. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but +C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added +C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and +C XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERMSG + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 XLIBR, XSUBR + CHARACTER*72 TEMP + CHARACTER*20 LFIRST +C***FIRST EXECUTABLE STATEMENT XERMSG + LKNTRL = J4SAVE (2, 0, .FALSE.) + MAXMES = J4SAVE (4, 0, .FALSE.) +C +C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. +C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE +C SHOULD BE PRINTED. +C +C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN +C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, +C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. +C + IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. + * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN + CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // + * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// + * 'JOB ABORT DUE TO FATAL ERROR.', 72) + CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) + CALL XERHLT (' ***XERMSG -- INVALID INPUT') + RETURN + ENDIF +C +C RECORD THE MESSAGE. +C + I = J4SAVE (1, NERR, .TRUE.) + CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) +C +C HANDLE PRINT-ONCE WARNING MESSAGES. +C + IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN +C +C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. +C + XLIBR = LIBRAR + XSUBR = SUBROU + LFIRST = MESSG + LERR = NERR + LLEVEL = LEVEL + CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) +C + LKNTRL = MAX(-2, MIN(2,LKNTRL)) + MKNTRL = ABS(LKNTRL) +C +C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS +C ZERO AND THE ERROR IS NOT FATAL. +C + IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 + IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 + IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 + IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 +C +C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A +C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) +C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG +C IS NOT ZERO. +C + IF (LKNTRL .NE. 0) THEN + TEMP(1:21) = 'MESSAGE FROM ROUTINE ' + I = MIN(LEN(SUBROU), 16) + TEMP(22:21+I) = SUBROU(1:I) + TEMP(22+I:33+I) = ' IN LIBRARY ' + LTEMP = 33 + I + I = MIN(LEN(LIBRAR), 16) + TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) + TEMP(LTEMP+I+1:LTEMP+I+1) = '.' + LTEMP = LTEMP + I + 1 + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE +C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE +C FROM EACH OF THE FOLLOWING THREE OPTIONS. +C 1. LEVEL OF THE MESSAGE +C 'INFORMATIVE MESSAGE' +C 'POTENTIALLY RECOVERABLE ERROR' +C 'FATAL ERROR' +C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE +C 'PROG CONTINUES' +C 'PROG ABORTED' +C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK +C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS +C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) +C 'TRACEBACK REQUESTED' +C 'TRACEBACK NOT REQUESTED' +C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT +C EXCEED 74 CHARACTERS. +C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. +C + IF (LKNTRL .GT. 0) THEN +C +C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. +C + IF (LEVEL .LE. 0) THEN + TEMP(1:20) = 'INFORMATIVE MESSAGE,' + LTEMP = 20 + ELSEIF (LEVEL .EQ. 1) THEN + TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' + LTEMP = 30 + ELSE + TEMP(1:12) = 'FATAL ERROR,' + LTEMP = 12 + ENDIF +C +C THEN WHETHER THE PROGRAM WILL CONTINUE. +C + IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. + * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN + TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' + LTEMP = LTEMP + 14 + ELSE + TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' + LTEMP = LTEMP + 16 + ENDIF +C +C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' + LTEMP = LTEMP + 20 + ELSE + TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' + LTEMP = LTEMP + 24 + ENDIF + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C NOW SEND OUT THE MESSAGE. +C + CALL XERPRN (' * ', -1, MESSG, 72) +C +C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A +C TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR + DO 10 I=16,22 + IF (TEMP(I:I) .NE. ' ') GO TO 20 + 10 CONTINUE +C + 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) + CALL FDUMP + ENDIF +C +C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. +C + IF (LKNTRL .NE. 0) THEN + CALL XERPRN (' * ', -1, ' ', 72) + CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) + CALL XERPRN (' ', 0, ' ', 72) + ENDIF +C +C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE +C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. +C + 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN +C +C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A +C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR +C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. +C + IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN + IF (LEVEL .EQ. 1) THEN + CALL XERPRN + * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) + ELSE + CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) + ENDIF + CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) + CALL XERHLT (' ') + ELSE + CALL XERHLT (MESSG) + ENDIF + RETURN + END diff --git a/SLATEC/src/xerprn.f b/SLATEC/src/xerprn.f new file mode 100644 index 0000000..97eedf4 --- /dev/null +++ b/SLATEC/src/xerprn.f @@ -0,0 +1,228 @@ +*DECK XERPRN + SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) +C***BEGIN PROLOGUE XERPRN +C***SUBSIDIARY +C***PURPOSE Print error messages processed by XERMSG. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERPRN-A) +C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C This routine sends one or more lines to each of the (up to five) +C logical units to which error messages are to be sent. This routine +C is called several times by XERMSG, sometimes with a single line to +C print and sometimes with a (potentially very long) message that may +C wrap around into multiple lines. +C +C PREFIX Input argument of type CHARACTER. This argument contains +C characters to be put at the beginning of each line before +C the body of the message. No more than 16 characters of +C PREFIX will be used. +C +C NPREF Input argument of type INTEGER. This argument is the number +C of characters to use from PREFIX. If it is negative, the +C intrinsic function LEN is used to determine its length. If +C it is zero, PREFIX is not used. If it exceeds 16 or if +C LEN(PREFIX) exceeds 16, only the first 16 characters will be +C used. If NPREF is positive and the length of PREFIX is less +C than NPREF, a copy of PREFIX extended with blanks to length +C NPREF will be used. +C +C MESSG Input argument of type CHARACTER. This is the text of a +C message to be printed. If it is a long message, it will be +C broken into pieces for printing on multiple lines. Each line +C will start with the appropriate prefix and be followed by a +C piece of the message. NWRAP is the number of characters per +C piece; that is, after each NWRAP characters, we break and +C start a new line. In addition the characters '$$' embedded +C in MESSG are a sentinel for a new line. The counting of +C characters up to NWRAP starts over for each new line. The +C value of NWRAP typically used by XERMSG is 72 since many +C older error messages in the SLATEC Library are laid out to +C rely on wrap-around every 72 characters. +C +C NWRAP Input argument of type INTEGER. This gives the maximum size +C piece into which to break MESSG for printing on multiple +C lines. An embedded '$$' ends a line, and the count restarts +C at the following character. If a line break does not occur +C on a blank (it would split a word) that word is moved to the +C next line. Values of NWRAP less than 16 will be treated as +C 16. Values of NWRAP greater than 132 will be treated as 132. +C The actual line length will be NPREF + NWRAP after NPREF has +C been adjusted to fall between 0 and 16 and NWRAP has been +C adjusted to fall between 16 and 132. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 880621 DATE WRITTEN +C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF +C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK +C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE +C SLASH CHARACTER IN FORMAT STATEMENTS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK +C LINES TO BE PRINTED. +C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF +C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. +C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Added code to break messages between words. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERPRN + CHARACTER*(*) PREFIX, MESSG + INTEGER NPREF, NWRAP + CHARACTER*148 CBUFF + INTEGER IU(5), NUNIT + CHARACTER*2 NEWLIN + PARAMETER (NEWLIN = '$$') +C***FIRST EXECUTABLE STATEMENT XERPRN + CALL XGETUA(IU,NUNIT) +C +C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD +C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD +C ERROR MESSAGE UNIT. +C + N = I1MACH(4) + DO 10 I=1,NUNIT + IF (IU(I) .EQ. 0) IU(I) = N + 10 CONTINUE +C +C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE +C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING +C THE REST OF THIS ROUTINE. +C + IF ( NPREF .LT. 0 ) THEN + LPREF = LEN(PREFIX) + ELSE + LPREF = NPREF + ENDIF + LPREF = MIN(16, LPREF) + IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX +C +C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE +C TIME FROM MESSG TO PRINT ON ONE LINE. +C + LWRAP = MAX(16, MIN(132, NWRAP)) +C +C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. +C + LENMSG = LEN(MESSG) + N = LENMSG + DO 20 I=1,N + IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 + LENMSG = LENMSG - 1 + 20 CONTINUE + 30 CONTINUE +C +C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. +C + IF (LENMSG .EQ. 0) THEN + CBUFF(LPREF+1:LPREF+1) = ' ' + DO 40 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) + 40 CONTINUE + RETURN + ENDIF +C +C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING +C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. +C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. +C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. +C +C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE +C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE +C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH +C OF THE SECOND ARGUMENT. +C +C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE +C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER +C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT +C POSITION NEXTC. +C +C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE +C REMAINDER OF THE CHARACTER STRING. LPIECE +C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, +C WHICHEVER IS LESS. +C +C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: +C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE +C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY +C BLANK LINES. THIS TAKES CARE OF THE SITUATION +C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF +C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE +C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC +C SHOULD BE INCREMENTED BY 2. +C +C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. +C +C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 +C RESET LPIECE = LPIECE-1. NOTE THAT THIS +C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. +C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY +C AT THE END OF A LINE. +C + NEXTC = 1 + 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) + IF (LPIECE .EQ. 0) THEN +C +C THERE WAS NO NEW LINE SENTINEL FOUND. +C + IDELTA = 0 + LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) + IF (LPIECE .LT. LENMSG+1-NEXTC) THEN + DO 52 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 54 + ENDIF + 52 CONTINUE + ENDIF + 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSEIF (LPIECE .EQ. 1) THEN +C +C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). +C DON'T PRINT A BLANK LINE. +C + NEXTC = NEXTC + 2 + GO TO 50 + ELSEIF (LPIECE .GT. LWRAP+1) THEN +C +C LPIECE SHOULD BE SET DOWN TO LWRAP. +C + IDELTA = 0 + LPIECE = LWRAP + DO 56 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 58 + ENDIF + 56 CONTINUE + 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSE +C +C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. +C WE SHOULD DECREMENT LPIECE BY ONE. +C + LPIECE = LPIECE - 1 + CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + 2 + ENDIF +C +C PRINT +C + DO 60 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) + 60 CONTINUE +C + IF (NEXTC .LE. LENMSG) GO TO 50 + RETURN + END diff --git a/SLATEC/src/xersve.f b/SLATEC/src/xersve.f new file mode 100644 index 0000000..6bd2a4f --- /dev/null +++ b/SLATEC/src/xersve.f @@ -0,0 +1,155 @@ +*DECK XERSVE + SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, + + ICOUNT) +C***BEGIN PROLOGUE XERSVE +C***SUBSIDIARY +C***PURPOSE Record that an error has occurred. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (XERSVE-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C *Usage: +C +C INTEGER KFLAG, NERR, LEVEL, ICOUNT +C CHARACTER * (len) LIBRAR, SUBROU, MESSG +C +C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) +C +C *Arguments: +C +C LIBRAR :IN is the library that the message is from. +C SUBROU :IN is the subroutine that the message is from. +C MESSG :IN is the message to be saved. +C KFLAG :IN indicates the action to be performed. +C when KFLAG > 0, the message in MESSG is saved. +C when KFLAG=0 the tables will be dumped and +C cleared. +C when KFLAG < 0, the tables will be dumped and +C not cleared. +C NERR :IN is the error number. +C LEVEL :IN is the error severity. +C ICOUNT :OUT the number of times this message has been seen, +C or zero if the table has overflowed and does not +C contain this message specifically. When KFLAG=0, +C ICOUNT will not be altered. +C +C *Description: +C +C Record that this error occurred and possibly dump and clear the +C tables. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 800319 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900413 Routine modified to remove reference to KFLAG. (WRB) +C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling +C sequence, use IF-THEN-ELSE, make number of saved entries +C easily changeable, changed routine name from XERSAV to +C XERSVE. (RWC) +C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERSVE + PARAMETER (LENTAB=10) + INTEGER LUN(5) + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB + CHARACTER*20 MESTAB(LENTAB), MES + DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) + SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG + DATA KOUNTX/0/, NMSG/0/ +C***FIRST EXECUTABLE STATEMENT XERSVE +C + IF (KFLAG.LE.0) THEN +C +C Dump the table. +C + IF (NMSG.EQ.0) RETURN +C +C Print to each unit. +C + CALL XGETUA (LUN, NUNIT) + DO 20 KUNIT = 1,NUNIT + IUNIT = LUN(KUNIT) + IF (IUNIT.EQ.0) IUNIT = I1MACH(4) +C +C Print the table header. +C + WRITE (IUNIT,9000) +C +C Print body of table. +C + DO 10 I = 1,NMSG + WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), + * NERTAB(I),LEVTAB(I),KOUNT(I) + 10 CONTINUE +C +C Print number of other errors. +C + IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX + WRITE (IUNIT,9030) + 20 CONTINUE +C +C Clear the error tables. +C + IF (KFLAG.EQ.0) THEN + NMSG = 0 + KOUNTX = 0 + ENDIF + ELSE +C +C PROCESS A MESSAGE... +C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, +C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. +C + LIB = LIBRAR + SUB = SUBROU + MES = MESSG + DO 30 I = 1,NMSG + IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. + * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. + * LEVEL.EQ.LEVTAB(I)) THEN + KOUNT(I) = KOUNT(I) + 1 + ICOUNT = KOUNT(I) + RETURN + ENDIF + 30 CONTINUE +C + IF (NMSG.LT.LENTAB) THEN +C +C Empty slot found for new message. +C + NMSG = NMSG + 1 + LIBTAB(I) = LIB + SUBTAB(I) = SUB + MESTAB(I) = MES + NERTAB(I) = NERR + LEVTAB(I) = LEVEL + KOUNT (I) = 1 + ICOUNT = 1 + ELSE +C +C Table is full. +C + KOUNTX = KOUNTX+1 + ICOUNT = 0 + ENDIF + ENDIF + RETURN +C +C Formats. +C + 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / + + ' LIBRARY SUBROUTINE MESSAGE START NERR', + + ' LEVEL COUNT') + 9010 FORMAT (1X,A,3X,A,3X,A,3I10) + 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) + 9030 FORMAT (1X) + END diff --git a/SLATEC/src/xgetua.f b/SLATEC/src/xgetua.f new file mode 100644 index 0000000..2e7db02 --- /dev/null +++ b/SLATEC/src/xgetua.f @@ -0,0 +1,51 @@ +*DECK XGETUA + SUBROUTINE XGETUA (IUNITA, N) +C***BEGIN PROLOGUE XGETUA +C***PURPOSE Return unit number(s) to which error messages are being +C sent. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XGETUA-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C XGETUA may be called to determine the unit number or numbers +C to which error messages are being sent. +C These unit numbers may have been set by a call to XSETUN, +C or a call to XSETUA, or may be a default value. +C +C Description of Parameters +C --Output-- +C IUNIT - an array of one to five unit numbers, depending +C on the value of N. A value of zero refers to the +C default unit, as defined by the I1MACH machine +C constant routine. Only IUNIT(1),...,IUNIT(N) are +C defined by XGETUA. The values of IUNIT(N+1),..., +C IUNIT(5) are not defined (for N .LT. 5) or altered +C in any way by XGETUA. +C N - the number of units to which copies of the +C error messages are being sent. N will be in the +C range from 1 to 5. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XGETUA + DIMENSION IUNITA(5) +C***FIRST EXECUTABLE STATEMENT XGETUA + N = J4SAVE(5,0,.FALSE.) + DO 30 I=1,N + INDEX = I+4 + IF (I.EQ.1) INDEX = 3 + IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) + 30 CONTINUE + RETURN + END diff --git a/pixi.toml b/pixi.toml index 7d8c937..1d9613b 100644 --- a/pixi.toml +++ b/pixi.toml @@ -9,7 +9,8 @@ version = "0.1.0" build-pac99 = "cd PAC99 && pixi build" build-thermp = "cd ThermP && pixi build" build-projrot = "cd ProjRot && pixi build" -build = { depends-on = ["build-pac99", "build-thermp", "build-projrot"] } +build-slatec = "cd SLATEC && pixi build" +build = { depends-on = ["build-pac99", "build-thermp", "build-projrot", "build-slatec"] } upload = "pixi run rattler-build upload anaconda -o Auto-Mech */*.conda" [dependencies]